C  ***CRYSTIN*** Written by Hundt & Sievers (University of Bonn 1987)
C
C  AWH 25 Apr 02 - Millennium bug fix
C  AWH 20 Oct 97 - opens "icsdemo" instead of "crystin" files if any args
C  Version 18 Aug 97 debugged by hewat@ill.fr (Alan Hewat) for SGI,HP,Sun...
C  Search on "AWH" for these changes.  The following are compile options:
C  SGI f77 icsd.f -O -static -Nl250 -bytereclen -o icsd
C  HP  f77 icsd.f -O -K -o icsd 
C  SUN f77 -O3 icsd.f -dn -onetrip -silent -Bstatic -o icsd 
C  DEC f77 icsd.f -O -K -convert big_endian -o icsd
C  LIN g77 -ff66 -w -fno-globals -fno-automatic -o icsd icsd.f
C  WIN g77 -ff66 -w -fno-globals -fno-automatic -o icsd icsd.f
C      And copy cygwin1.dll to somewhere in your %PATH% eg C:\WINDOWS

C ----------------------------------------OWNUNC411----UPD880525--ICSDM
      PROGRAM ICSDM
CC
CC    HP-UX VERSION      (25.5.88)
CC
      CHARACTER*8 DDBASE,DDINDX
      character filen*7                                                 !AWH 19 Aug 97
      logical ifdata                                                    !AWH 19 Aug 97
CC
      COMMON /SETUP/  KBASES,KDPROP(60)
      COMMON /DC2201/ IFLAG(50)
CC
CC---DEFINE KEYBOARD, DISPLAY AND PRINTER
      DATA NTIN/ 5/, NTDSPL/ 6/, NTPRT/11/
CC
CC---AUTHORITY CODE
      DATA IAUTH/65535/
CC
CC---UNIT NUMBER OF THE SETUP FILE
      DATA ISETUP/39/
CC
CC***************************************************
CC---LOGICAL RECORD LENGTH OF THE DIRECT ACCESS FILES
CC    (MUST BE 80, 160, 1520 OR 3040)
      DATA LRECL/3040/
      data filen/"crystin"/                                             !AWH 19 Aug 97
CC***************************************************
CC
      IFLAG(44) = 3040/LRECL
      IFLAG(19) = IAUTH
CC
CC---SET A FLAG: DATABASE DEFINITIONS LOADED FROM THE SETUP FILE
CC    AND STORED IN COMMON /SETUP/
      IFLAG(47) = 1
      IFLAG(47) = 0
CC
C **************************************
C ---OPENING OF RANDOM FILES
C **************************************
C
C  DATABASE, INDEX FILE (ICSD)

      nargs = iargc ( )                                                 !AWH demo if arguments
      if (nargs .ge. 1) filen="icsdemo"                 !AWH 19 Aug 97

cuw   OPEN(UNIT=1,ACCESS='DIRECT',RECL=LRECL,
cuw  1   FILE='/disc1/bases/icsd/db')
cuw
cuw   OPEN(UNIT=2,ACCESS='DIRECT',RECL=LRECL,
cuw  1   FILE='/disc1/bases/icsd/index')
cuw
CC TABLES FILE...
cuw   ITBLS = 3
cuw   OPEN(UNIT=ITBLS,ACCESS='DIRECT',RECL=LRECL,
cuw  1   FILE='/disc1/bases/icsd/tables')
CC
CC SCRATCH FILE...
cuw   OPEN (UNIT=10 , ACCESS = 'DIRECT' , RECL =LRECL)
CC
CC----DATABASE...
C      OPEN (UNIT=1,file='crystin.data',ACCESS='DIRECT',
C  Check that data files exist. If not, try alternative         !AWH 19 Aug 97
                inquire(file=filen//'.data',exist=ifdata)       !AWH 19 Aug 97
      if(ifdata)inquire(file=filen//'.index',exist=ifdata)      !AWH 19 Aug 97
      if(ifdata)inquire(file=filen//'.tables',exist=ifdata)     !AWH 19 Aug 97
      if(.not.ifdata) then                                                                      !AWH 19 Aug 97
        if(filen.eq."crystin") then                                                     !AWH 19 Aug 97
          filen="icsdemo"                                                                       !AWH 19 Aug 97
        else                                                                                            !AWH 19 Aug 97
          filen="crystin"                                                                       !AWH 19 Aug 97
        end if                                                                                          !AWH 19 Aug 97
      end if                                                                                            !AWH 19 Aug 97
      OPEN (UNIT=1,file=filen//'.data',ACCESS='DIRECT',         !AWH 19 Aug 97
     1      FORM='UNFORMATTED',RECL=3040,STATUS='OLD',ERR=99)
CC----INDEX FILE ...
C      OPEN (UNIT=2,file='crystin.index',ACCESS='DIRECT',
      OPEN (UNIT=2,file=filen//'.index',ACCESS='DIRECT',        !AWH 19 Aug 97
     1      FORM='UNFORMATTED',RECL=3040,STATUS='OLD',ERR=99)
CC----TABLES FILE...
      ITBLS = 3
C      OPEN (UNIT=ITBLS,file='crystin.tables',ACCESS='DIRECT',
      OPEN (UNIT=ITBLS,file=filen//'.tables',ACCESS='DIRECT',   !AWH 19 Aug 97
     1      FORM='UNFORMATTED',RECL=3040,STATUS='OLD',ERR=99)
CC----SCRATCH FILE...
C      OPEN (UNIT=10,file='crystin.scratch',ACCESS='DIRECT',
      OPEN (UNIT=10,file=filen//'.scratch',ACCESS='DIRECT',     !AWH 19 Aug 97
     1      FORM='UNFORMATTED',RECL=3040,STATUS='unknown')

CC
CC KEYBOARD - FILE  5
CC DISPLAY  - FILE  6
CC PRINTER  - FILE 11 (OR DUMMY)
cuw   open (unit=11,file='crystin.print')
CC SPECIAL OUTPUT (FORMATTED) - FILE 4 (OR DUMMY)
cuw   open (unit=4,file='crystin.lcff')
CC
CC
CC---PERFORM THE ADAPTATION TEST
c     CALL DB2335(0,NTDSPL,ITBLS)
CC
CC---INVOKE THE CRYSTIN COMMAND INTERPRETER
      CALL DB2280(NTIN,NTDSPL,NTPRT)
      CALL TERMIC
   99 STOP
      END
C ----------------------------------------OWNUNC411----UPD880525--ASCE
C
C     HP-UX VERSION ----------------------------------
C
      SUBROUTINE ASCE  (ISTR  ,ISTRT,LEN)
C
C ---CONVERT A STRING FROM  ASCII TO EBCDIC
C
C     ISTR   - IN THE CALLING PROGRAM: INTEGER*4 ARRAY
C     ISTRT  - FIRST CHARACTER TO BE CONVERTED (NOTE: EACH ELEMENT
C              OF THE INTEGER*4 ARRAY CONTAINS 4 CHARACTERS!)
C     LEN    - NUMBER OF CHARACTERS TO BE CONVERTED
C
      character*1 ISTRNG(1), LTABL(128), LP(4), cwort(4)
      INTEGER*4 ITABL(32),istr(*)
      EQUIVALENCE (ITABL(1),LTABL(1)), (IP,LP(1))
      equivalence (istrng(1),nstrng)
      equivalence (cwort(1),iwort)
cuw      0  1  2  3     4  5  6  7     8  9  A  B     C  D  E  F
cuw    DATA ITABL /
cuw  * Z'6F 6F 6F 6F',Z'6F 6F 6F 6F',Z'6F 6F 6F 6F',Z'6F 6F 6F 6F',
cuw
cuw  1 Z'6F 6F 6F 6F',Z'6F 6F 6F 6F',Z'6F 6F 6F 6F',Z'6F 6F 6F 6F',
cuw
cuw  2 Z'40 5A 7F 7B',Z'5B 6C 50 7D',Z'4D 5D 5C 4E',Z'6B 60 4B 61',
cuw
cuw  3 Z'F0 F1 F2 F3',Z'F4 F5 F6 F7',Z'F8 F9 7A 5E',Z'4C 7E 6E 6F',
cuw
cuw  4 Z'7C C1 C2 C3',Z'C4 C5 C6 C7',Z'C8 C9 D1 D2',Z'D3 D4 D5 D6',
cuw
cuw  5 Z'D7 D8 D9 E2',Z'E3 E4 E5 E6',Z'E7 E8 E9 6F',Z'6F 6F 5F 6D',
cuw
cuw  6 Z'6F C1 C2 C3',Z'C4 C5 C6 C7',Z'C8 C9 D1 D2',Z'D3 D4 D5 D6',
cuw
cuw  7 Z'D7 D8 D9 E2',Z'E3 E4 E5 E6',Z'E7 E8 E9 6F',Z'6F 6F 6F 6F'/
cuw
C        0 1 2 3     4 5 6 7     8 9 A B     C D E F
       DATA ITABL /
     * Z'6F6F6F6F',Z'6F6F6F6F',Z'6F6F6F6F',Z'6F6F6F6F',
C
     1 Z'6F6F6F6F',Z'6F6F6F6F',Z'6F6F6F6F',Z'6F6F6F6F',
C
Cmw     2 Z'405A7F7B',Z'5B6C507D',Z'4D5D5C4E',Z'6B604B61',
     2 Z'7B7F5A40',Z'7D506C5B',Z'4E5C5D4D',Z'614B606B',
C
Cmw     3 Z'F0F1F2F3',Z'F4F5F6F7',Z'F8F97A5E',Z'4C7E6E6F',
     3 Z'F3F2F1F0',Z'F7F6F5F4',Z'5E7AF9F8',Z'6F6E7E4C',
C
Cmw     4 Z'7CC1C2C3',Z'C4C5C6C7',Z'C8C9D1D2',Z'D3D4D5D6',
     4 Z'C3C2C17C',Z'C7C6C5C4',Z'D2D1C9C8',Z'D6D5D4D3',
C
Cmw     5 Z'D7D8D9E2',Z'E3E4E5E6',Z'E7E8E96F',Z'6F6F5F6D',
     5 Z'E2D9D8D7',Z'E6E5E4E3',Z'6FE9E8E7',Z'6D5F6F6F',
C
Cmw     6 Z'6FC1C2C3',Z'C4C5C6C7',Z'C8C9D1D2',Z'D3D4D5D6',
     6 Z'C3C2C16F',Z'C7C6C5C4',Z'D2D1C9C8',Z'D6D5D4D3',
C
Cmw     7 Z'D7D8D9E2',Z'E3E4E5E6',Z'E7E8E96F',Z'6F6F6F6F'/
     7 Z'E2D9D8D7',Z'E6E5E4E3',Z'6FE9E8E7',Z'6F6F6F6F'/
C
c
c
      DATA IP/0/
c
c----Adresse des ersten 4-Byte-Wortes
      iad4 = (istrt + 3)/4
c
c----dieses Wort herauskopieren
      iwort =  istr(iad4)
c
c----Byte-Nummer im herauskopierten Wort
      iad1 = istrt + 4 - 4*iad4
c
      DO 20 J = 1,len
c----adressiertes Byte nach rechts shiften
      ip = 0
Cmw      lp(4) = cwort(iad1)
      lp(1) = cwort(iad1)
      cwort(iad1) = LTABL(ip+1)
      istr(iad4) = iwort
c
      if (iad1 .ge. 4) then
         IAD1 = 1
         istr(iad4) = iwort
         IAD4 = IAD4 + 1
         IWORT = ISTR(IAD4)
      else
         IAD1 = IAD1 + 1
      end if
20    continue
c
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880524--CHRINT
C
C
C  ******************************************************
C  *                                                    *
C  *                   ========                         *
C  *  THIS PROGRAM IS  = SLOW =                         *
C  *                   ========                         *
C  *                              ========              *
C  *  IT SHOULD BE REPLACED BY A  = FAST =  PROGRAM AS  *
C  *  SOON AS POSSIBLE.           ========              *
C  *                                                    *
C  ******************************************************
C
C
C
CC    HP-UX-VERSION ------------------------
C
cchrint        ----------------------------------------
                subroutine chrint (istrng,istrt,len,n)
c              ----------------------------------------
c
c          konversion von 1-4 charactern in eine integerzahl
c
c              ----------------------------------------
c
      dimension istrng(1)
      n = 0
Cmw      call copych (istrng,istrt,len,n,5-len)
      do 2999 i=1,len
        call copych(istrng,istrt+i-1,1,n,len-i+1)
2999  continue
      return
      END
C ----------------------------------------OWNUNC411----UPD880527--CICDC
CYCDCY      RETURN
CC
CC    HP-UX-VERSION   ----------------------

      SUBROUTINE CICDC (ISTRNG,ISTART,LEN)
      DIMENSION ISTRNG(*)
      CALL EBCA (ISTRNG,ISTART,LEN)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--CICDCS
      SUBROUTINE CICDCS (STR1,IADR1,LENG, STR2)
c
      integer str1(*),str2(*)
c
      call copych (str1,iadr1,leng,str2,iadr1)
      call ebca (str2,iadr1,leng)
c
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850830--CLEAR
      SUBROUTINE CLEAR
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--CONVCI
C
C ---THIS PROGRAMM CONVERTS A CHARACTER FROM EBCDIC TO
C     AN INTEGER*4 NUMBER. IT IS USED IN THE FOLLOWING WAY:
C
C     CALL CONVCI(ISTRNG,IPOS,IZIF)
C
C     ISTRNG: INTEGER*4 VARIABLE OR ARRAY CONTAINING THE CHARACTER
C             WHICH IST TO BE CONVERTED
C     IPOS:   POSITION OF THE CHARACTER WITHIN ISTRNG.
C             NOTE: ISTRNG(1) CONTAINS CHARACTERS # 1,2,3,4 (PACKED);
C             ISTRNG(2) CONTAINS # 5,6,7,8, AND SO ON.
C
C     IZIF:   RESULT OF CONVERSION.
C             0...9 : NUMERIC VALUE OF THE CHARACTERS 0 TO 9
C             -1    : SPACE
C             -2    : PERIOD (.)
C             -3    : HYPHEN, MINUS (-)
C             -4    : ALL OTHER CHARACTERS
C
C        +----------------------------------------+
C        I IT IS STRONGLY RECOMMENDED TO REPLACE  I
C        I THIS PROGRAM BY A FAST MACHINE ROUTINE I
C        +----------------------------------------+
C
      SUBROUTINE CONVCI(ISTRNG,IPOS,IZIF)
C
      INTEGER ISTRNG(*),WORT,BYTE
C     LOGICAL*1 IHL(4), LHS(4)
      CHARACTER*1 IHL(4), LHS(4)
      EQUIVALENCE (IH,IHL(1)), (IHS,LHS(1))
      DATA IH/0/
      WORT = (IPOS+3) / 4
      BYTE = IPOS + 4 -(4*WORT)
      IHS = ISTRNG(WORT)
Cmw      IHL(4) = LHS(BYTE)
      IHL(1) = LHS(BYTE)
      IF(IH .EQ. 64) GO TO 200
      IF(IH .GT. 249) GO TO 300
      IF(IH .LT. 240) GO TO 300
      IZIF = IH - 240
      RETURN
  200 IZIF = -1
      RETURN
  300 IZIF = -4
      IF(IH .EQ. 75) IZIF = -2
      IF(IH .EQ. 96) IZIF = -3
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880524--COPYCH
C
C ---PROGRAM TO COPY A SUBSTRING OF STRING STR1 TO STR2.
C
C     THIS PROGRAMM MUST BE CALLED IN THE FOLLOWING WAY:
C     CALL COPYCH (ISTR1,IORG1,LENGTH,ISTR2,IORG2)
C
C     ISTR1:  ARRAY (NORMALLY TYPE INTEGER), CONTAINING THE SUBSTRING
C             TO BE COPIED. EVERY ARRAY ELEMENT CONTAINS EXACTLY
C             4 8-BIT-CHARACTERS ("PACKED CHARACTERS").
C     IORG1:  POSITION OF THE FIRST CHARACTER OF THE SUBSTRING TO BE
C             COPIED. THE FIRST ELEMENT OF ARRAY ISTR1 CONTAINS THE
C             POSITIONS 1, 2, 3 AND 4, THE SECOND 5, 6, 7 AND 8 AND SO
C             ON.
C     LENGTH: NUMBER OF CHARACTERS (NOT ARRAY ELEMENTS!) IN THE
C             SUBSTRING. MUST NEVER BE ZERO OR NEGATIVE.
C     ISTR2:  DESTINATION ARRAY (NORMALLY TYPE INTEGER).
C     IORG2:  POSITION OF THE FIRST CHARACTER IN ISTR2, WHICH IS
C             OVERWRITTEN BY THE COPIED SUSBSTRING.
C
C     **********************************************
C     *  THIS PROGRAM SHOULD BE REPLACED BY A FAST *
C     *  MACHINE ROUTINE IF POSSIBLE.              *
C     **********************************************
C
CYCDCY      RETURN
CC
CC    HP-UX-VERSION   --------------------------------
CC
      subroutine copych (istr,istrt,len, jdest,jstrt)
C      dimension istr(1),jdest(1)
      dimension istr(*),jdest(*)                !AWH 20/10/97
      character*1 lh(4),ch(4),chj(4)
      equivalence (ih,lh(1)),(ich,ch(1)),(jch,chj(1))
c
      iws=(istrt+3)/4
      jws=(jstrt+3)/4
      ibs=istrt-(iws-1)*4
      jbs=jstrt-(jws-1)*4
      jch=jdest(jws)
c
      i=0
      go to 25
11    jbs=1
      jws=jws+1
      jch=jdest(jws)
15    ibs=ibs+1
      if (ibs-4) 5,5,20
20    iws=iws+1
      ibs=1
25    ich=istr(iws)
c
5     i=i+1
      chj(jbs)=ch(ibs)
      if (i-len) 6,10,10
6     jbs=jbs+1
      if (jbs-4) 15,15,10
10    jdest(jws)=jch
      if (i-len) 11,999,999
999   continue
      return
      END
C ----------------------------------------OWNUNC411----UPD850830--DB0100
      SUBROUTINE DB0100 (NBUF,NDIM,NWRDS1,MAXBL1,NPRT1,NVER1,NSF1)
      COMMON /DC0100/ NREC,NFLAG,NSEQ,NFILE,NTEXT,NSF,NSFPNT,
     2       NBLSIZ,NWORDS,MAXBLK,NPRINT,NVERFY,NBUFST,IOPEN,IWRITE,
     3       NPCNT,ISTOPF,NRDCNT,NWRCNT
      INTEGER NBUF(NDIM)
      DATA INIT /0/
      IF (INIT.EQ.0) IOPEN = 0
      INIT = 1
      IWRITE = 0
      IF (IOPEN.GT.0) CALL DB0105 (NBUF)
      NWORDS = NWRDS1
      MAXBLK = MAXBL1
      NPRINT = NPRT1
      NVERFY = NVER1
      NSF    = NSF1
      NSFPNT = 0
      NPCNT  = 0
      ISTOPF = 0
      NRDCNT = 0
      NWRCNT = 0
      NBLSIZ = 4*NWORDS
      IF (4*MAXBLK+NWORDS*MAXBLK .GT. NDIM) GOTO 900
      NREC   = 0
      NFLAG  = NREC+MAXBLK
      NSEQ   = NFLAG+MAXBLK
      NFILE  = NSEQ+MAXBLK
      NTEXT  = NFILE+MAXBLK+1
      NBUF(NTEXT) = 2147483647
      NBUFST = NBUF(NTEXT)
      DO 50 I=1,MAXBLK
      NBUF(NREC+I)  = 0
      NBUF(NFLAG+I) = 0
      NBUF(NSEQ+I)  = MAXBLK-I+1
      NBUF(NFILE+I) = -1
   50 CONTINUE
      RETURN
  900 WRITE (NPRINT,10090)
10090 FORMAT (' DB010090 ERROR, NOT ENOUGH BUFFER AREA DEFINED')
      CALL TERMIC
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850830--DB0101
      SUBROUTINE DB0101 (NF, NPOS, NSTRNG, NST, LEN, NBUF)
      INTEGER NSTRNG(*), NBUF(*)
      CALL DB0103 (1, NF, NPOS, NSTRNG, NST, LEN, NBUF)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850830--DB0102
      SUBROUTINE DB0102 (NF, NPOS, NSTRNG, NST, LEN, NBUF)
      INTEGER NSTRNG(*), NBUF(*)
      CALL DB0103 (2, NF, NPOS, NSTRNG, NST, LEN, NBUF)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850830--DB0103
      SUBROUTINE DB0103 (IO, NF, NPOS, NSTRNG, NST, LEN, NBUF)
      COMMON /DC0100/ NREC,NFLAG,NSEQ,NFILE,NTEXT,NSF,NSFPNT,
     2       NBLSIZ,NWORDS,MAXBLK,NPRINT,NVERFY,NBUFST,IOPEN,IWRITE,
     3       NPCNT,ISTOPF,NRDCNT,NWRCNT
      INTEGER NBUF(*),NSTRNG(*)
      DATA NN1/1/
      IF (LEN.LE.0) GOTO 900
      IF (NPOS.LT.0) GOTO 910
      IF (NBUF(NTEXT).NE.NBUFST) GOTO 920
      NRECW = NPOS/NBLSIZ + 1
      NREL = NPOS - NBLSIZ*(NRECW-1) + 1
      LEN1 = LEN
      IPOINT = NST + 1
  100 INFL = 1
      IF (IO.LT.2) GOTO 110
      IF (NREL.GT.1) GOTO 110
      IF (LEN1.LT.NBLSIZ) GOTO 110
      INFL = 0
  110 CALL DB0104 (NBUF, NF, NRECW, INFL, NBLK)
      IF (NBLK.EQ.1) NBUFST=NBUF(NTEXT)
      LEN2 = NBLSIZ - NREL + 1
      IF (LEN2.GT.LEN1) LEN2=LEN1
      GOTO (210,220), IO
  210 IF (LAND(NVERFY,NN1).GT.0)
     2    WRITE (NPRINT,10210) NREL,LEN2,IPOINT,NSTRNG(1)
10210 FORMAT(' DB010321 NREL=',I5,' LEN=',I5,' IPOINT=',I5,' STRNG=',Z8)
      CALL COPYCH (NBUF(NWORDS*(NBLK-1)+NTEXT),NREL,LEN2,NSTRNG,IPOINT)
      GOTO 250
  220 IF (LAND(NVERFY,NN1).GT.0)
     2    WRITE (NPRINT,10220) NREL,LEN2,IPOINT,NSTRNG(1)
10220 FORMAT(' DB010322 NREL=',I5,' LEN=',I5,' IPOINT=',I5,' STRNG=',Z8)
      CALL COPYCH (NSTRNG,IPOINT,LEN2,NBUF(NWORDS*(NBLK-1)+NTEXT),NREL)
      NBUF(NFLAG+NBLK) = 1
      IF (NBLK.EQ.1) NBUFST=NBUF(NTEXT)
      IF (IWRITE.LT.2) GOTO 250
      CALL DB0107 (NF,NBLK,NRECW,NBUF(NTEXT+NWORDS*(NBLK-1)),NWORDS)
      NBUF(NFLAG+NBLK) = 0
  250 IPOINT=IPOINT+LEN2
      LEN1=LEN1-LEN2
      NRECW=NRECW+1
      NREL=1
      IF (LEN1.GT.0) GOTO 100
      RETURN
  900 WRITE (NPRINT,10000) LEN
10000 FORMAT (' DB010300 ERROR, INVALID LENGTH,',I8)
      CALL TERMIC
  910 WRITE (NPRINT,10010) NPOS
10010 FORMAT (' DB010310 ERROR, INVALID POSITION,',I8)
      CALL TERMIC
  920 WRITE (NPRINT,10020) NBUFST,NBUF(NTEXT)
10020 FORMAT (' DB010320 ERROR, BUFFER MISMATCHED: ',Z8,'/',Z8)
      CALL TERMIC
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850830--DB0104
      SUBROUTINE DB0104 (NBUF,NF,NRECW,INFL,NBLK)
      COMMON /DC0100/ NREC,NFLAG,NSEQ,NFILE,NTEXT,NSF,NSFPNT,
     2       NBLSIZ,NWORDS,MAXBLK,NPRINT,NVERFY,NBUFST,IOPEN,IWRITE,
     3       NPCNT,ISTOPF,NRDCNT,NWRCNT
      INTEGER NBUF(*)
      DATA NN2/2/
      DO 100 NBLK=1,MAXBLK
      IF (NBUF(NFILE+NBLK).NE.NF) GOTO 100
      IF (NBUF(NREC+NBLK).EQ.NRECW) GOTO 200
  100 CONTINUE
      NBLK=1
      DO 150 I=1,MAXBLK
      NBUF(NSEQ+I) = NBUF(NSEQ+I) + 1
      IF (NBUF(NSEQ+I).GT.MAXBLK) NBLK=I
  150 CONTINUE
      IF (NBUF(NFLAG+NBLK)) 170,170,160
  160 N  = NBUF(NFILE+NBLK)
      NR = NBUF(NREC+NBLK)
      CALL DB0107 (N,NBLK,NR,NBUF(NTEXT+NWORDS*(NBLK-1)),NWORDS)
      NBUF(NFLAG+NBLK) = 0
  170 NBUF(NREC+NBLK) = NRECW
      NBUF(NFILE+NBLK) = NF
      IF (INFL.EQ.1)
     2  CALL DB0106 (NF,NBLK,NRECW,NBUF(NTEXT+NWORDS*(NBLK-1)),NWORDS)
      GOTO 300
  200 N = NBUF(NSEQ+NBLK)
      DO 250 I=1,MAXBLK
      IF (NBUF(NSEQ+I).LT.N) NBUF(NSEQ+I) = NBUF(NSEQ+I) + 1
  250 CONTINUE
  300 NBUF(NSEQ+NBLK) = 1
      IF (LAND(NVERFY,NN2).GT.0) WRITE (NPRINT,10300) NBLK,NRECW,NF
10300 FORMAT (' DB010430 GETBLK ALLOCATED BLKNR.',I3,' TO RECNR.',I6,
     2  ' ON FILE',I3)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850830--DB0105
      SUBROUTINE DB0105 (NBUF)
      INTEGER NBUF(*)
      COMMON /DC0100/ NREC,NFLAG,NSEQ,NFILE,NTEXT,NSF,NSFPNT,
     2       NBLSIZ,NWORDS,MAXBLK,NPRINT,NVERFY,NBUFST,IOPEN,IWRITE,
     3       NPCNT,ISTOPF,NRDCNT,NWRCNT
      IF (NBUFST.NE.NBUF(NTEXT)) GOTO 900
      IOPEN = 0
      NRDCNT = 0
      NWRCNT = 0
      DO 100 I=1,MAXBLK
      IF (NBUF(NFLAG+I)) 100,100,90
   90 NF = NBUF(NFILE+I)
      NR = NBUF(NREC+I)
      CALL DB0107 (NF,I,NR,NBUF(NTEXT+NWORDS*(I-1)),NWORDS)
  100 CONTINUE
      RETURN
  900 WRITE (NPRINT,9000) NBUFST,NBUF(NTEXT)
 9000 FORMAT (' DB010500 ERROR, BUFFER MISMATCHED: ',Z8,'/',Z8)
      CALL TERMIC
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880524--DB0106
CC
Cc    hp-ux-version   ------------------------
Cc
CDB0106       *****   R E A D B L K   *****
C
      SUBROUTINE DB0106 (NF,NBLK,NR,NBUF,NDIM)
C
      COMMON /DC0100/ NREC,NFLAG,NSEQ,NFILE,NTEXT,NSF,NSFPNT,
CAWH 2   NBLSIZ,NWORDS,MAXBLK,NPRINT,NVERFY,NBUFST,IOPEN,IWRIT
     2   NBLSIZ,NWORDS,MAXBLK,NPRINT,NVERFY,NBUFST,IOPEN,IWRITE,
     3   NPCNT,ISTOPF,NRDCNT,NWRCNT
C
      INTEGER NBUF(NDIM)
      DATA NN4/4/
CC
CC****************************************************************
CC****************************************************************
CC**
CC**  THIS IS THE DIRECT ACCESS DATA INPUT "BOTTLE NECK".
CC**  IT MUST POSSIBLY BE MODIFIED ACCORDING TO LOCAL REQUIREMENTS
CC**  MOSTLY TOGETHER WITH FILE DEFINITIONS IN DB2201.
CC**
CC**  IN THIS POINT THE PHYSICAL BLOCK NO. NR OF DATA (CONTAINING
CC**  E X A C T L Y 3040 8-BIT-CHARACTERS) IS COPIED FROM DIRECT
CC**  ACCESS DATA SET NO. NF INTO THE ARRAY NBUF. THIS ARRAY IS
CC**  DIMENSIONED WITH 760 IN THE CALLING PROGRAM; NDIM HAS THE
CC**  ACTUAL VALUE 760.
CC**
CC**  EACH WORD OF THE ARRAY NBUF MUST BE FILLED WITH E X A C T L
CC**  4 8-BIT-CHARACTERS.
CC**
      READ (NF,REC=NR) NBUF
      NRDCNT = NRDCNT + 1
CC**
CC****************************************************************
CC****************************************************************
CC
C
      NPCNT = NPCNT + 1
      IF (LAND(NVERFY,NN4).GT.0) WRITE (NPRINT,1000) NBLK,NR,NF
 1000 FORMAT(' DB010600 Buffer nr.',I3,' filled with rec. nr.',I5,
     2  ' of unit',I3)
C
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB0107
      SUBROUTINE DB0107 (NF,NBLK,NR,NBUF,NDIM)
      COMMON /DC0100/ NREC,NFLAG,NSEQ,NFILE,NTEXT,NSF,NSFPNT,
     2 NBLSIZ,NWORDS,MAXBLK,NPRINT,NVERFY,NBUFST,IOPEN,IWRITE,
     3 NPCNT,ISTOPF,NRDCNT,NWRCNT
      INTEGER NBUF(NDIM)
      N = NF
      WRITE (NF,REC=NR) NBUF
      NPCNT = NPCNT + 1
      NWRCNT = NWRCNT + 1
      IF (NVERFY.GT.0) WRITE (NPRINT,10000) NBLK,NR,N
10000 FORMAT(' DB0107 - BLOCK NR.',I3,' WRITTEN TO REC. NR.',I5,
     2  ' ON FILE',I3)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB0112
      SUBROUTINE DB0112 (NFILE,NDIR,NBL,NBLSIZ,NFCB,NBRAS)
      INTEGER NFCB(64),NBRAS(*),NENT(2)
      DATA LDIR/7/, NENT/2147483647,0/
      DO 10 I=1,64
   10 NFCB(I) = 0
      NFCB(26) = NBL*NBLSIZ
      NFCB(27) = 256
      N = 256+LDIR*NDIR
      K = 80*(N/80)
      IF (K.LT.N) K = K + 80
      NFCB(28) = K
      NFCB(29) = K
      NFCB(30) = LDIR
      NFCB(31) = NDIR
      NFCB(33) = NFILE
      NFCB(34) = NENT(1) -1
      NFCB(35) = -1
      NFCB(36) = 0
      NFCB(37) = 0
      NFCB(38) = -1
      NFCB(39) = 0
      NFCB(40) = 0
      NFCB(41) = 1
      CALL DB0102 (NFILE,0,NFCB,0,256,NBRAS)
      N = 256
      DO 100 I=1,NDIR
      CALL DB0102 (NFILE,N,NENT,0,7,NBRAS)
      N = N + 7
  100 CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB0120
      SUBROUTINE DB0120 (NF,NP,NV,NFCB,NBRAS)
      COMMON /DC0120/ NPRINT,NVERFY,NDEL
      INTEGER NFCB(64),NBRAS(*)
      NPRINT = NP
      NVERFY = NV
      NDEL = 2147483647
      CALL DB0101 (NF,0,NFCB,0,256,NBRAS)
      IF (NFCB(41).NE.0) GOTO 900
      NFCB(33) = NF
      NFCB(34) = NDEL - 1
      NFCB(35) = -1
      NFCB(36) = 0
      NFCB(37) = 0
      NFCB(38) = -1
      NFCB(39) = 0
      NFCB(40) = 0
      DO 200 I=43,60
  200 NFCB(I) = 0
      DO 300 J = 26,32
      CALL CHRINT(NFCB(J),1,4,I)
      NFCB(J) = I
  300 CONTINUE
      IF (NVERFY.GT.0) WRITE (NPRINT,10000) NFCB(1),NFCB(2)
10000 FORMAT (' DB012000 PDS ',2A4,' OPENED')
      RETURN
  900 WRITE (NPRINT,10900) NF,(NFCB(I),I=9,14)
10900 FORMAT (/' DB012090  *** WARNING! ***  UNIT',I3,' NOT CLOSED, ',
     2 2A4,2I7,1X,2A4)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB0121
      SUBROUTINE DB0121 (MEMNR,MEMSTR,NPOS,MAXLEN,LEN,NFCB,NBRAS)
      COMMON /DC0120/ NPRINT,NVERFY,NDEL
      INTEGER MEMSTR(*),NFCB(64),NBRAS(*)
      IF (NFCB(34).NE.NDEL-1) GOTO 903
      IF (MEMNR.LE.0) GOTO 200
      IF (MEMNR.GT.NFCB(31)) GOTO 902
      NF = NFCB(33)
      IF (MEMNR.EQ.NFCB(35)) GOTO 100
      NFCB(35) = MEMNR
      CALL DB0128 (MEMNR,IDIR,NFCB(36),NFCB(37),NFCB,NBRAS)
      IF (NFCB(36).EQ.NDEL) GOTO 200
      IF (NVERFY.GT.0) WRITE (NPRINT,10010) MEMNR,NFCB(36),NFCB(37)
10010 FORMAT (' DB012110 MEMBER',I7,' OPENED FOR INPUT, START AT',I8,
     2  ', LENGTH =',I7)
  100 LEN = NFCB(37)
      IF (LEN.LE.0) GOTO 200
      IF (LEN.GT.MAXLEN) LEN = MAXLEN
      IF (NVERFY.GT.1) WRITE(NPRINT,10020) NFCB(36),LEN
10020 FORMAT (' DB012120 READING INPUTSTRING, START AT',I8,
     2   ', LENGTH =',I7)
      CALL DB0101 (NF,NFCB(36),MEMSTR,NPOS,LEN,NBRAS)
      NFCB(36) = NFCB(36) + LEN
      NFCB(37) = NFCB(37) - LEN
      IF (LEN.LT.MAXLEN) GOTO 210
      RETURN
  200 LEN = 0
  210 NFCB(35) = -1
      RETURN
  902 WRITE (NPRINT,10092) MEMNR
10092 FORMAT (' DB012192 INVALID MEMBERNR.,',I10)
      LEN = -2
      RETURN
  903 WRITE (NPRINT,10093)
10093 FORMAT (' DB012193 PDS NOT OPEN')
      LEN=-1
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB0122
      SUBROUTINE DB0122 (MEMNR,MEMSTR,MPOS,LEN,IRC,NFCB,NBRAS)
      COMMON /DC0120/ NPRINT,NVERFY,NDEL
      INTEGER MEMSTR(*),NFCB(64),NBRAS(*)
      IF (NFCB(34).NE.NDEL-1) GOTO 903
      IF (MEMNR.LE.0.OR.MEMNR.GT.NFCB(31)) GOTO 902
      CALL DB012C (NFCB,NBRAS)
      IRC = MEMNR
      NF = NFCB(33)
      IF (NFCB(38).LE.0) GOTO 100
      IF (MEMNR.EQ.NFCB(38)) GOTO 200
      CALL DB0124 (NFCB,NBRAS)
  100 CALL DB0128 (MEMNR,IDIR,NPOSA,LENA,NFCB,NBRAS)
      IF (LENA.LT.-2) GOTO 902
      IRC = LENA
      IF (IRC.LT.0) IRC = IRC + 1
      NFCB(38) = MEMNR
      NFCB(39) = NFCB(29)
      NFCB(40) = NFCB(29)
  200 IF (NFCB(40)+LEN.GT.NFCB(26)) GOTO 905
      IF(NVERFY.GT.1) WRITE (NPRINT,10020) NFCB(40),LEN
10020 FORMAT(' DB012220 WRITING OUTPUTSTRING, START AT',I8,
     2  ', LENGTH =',I7)
      IF (LEN.LE.0) RETURN
      CALL DB0102 (NF,NFCB(40),MEMSTR,MPOS,LEN,NBRAS)
      NFCB(40) = NFCB(40)+LEN
      RETURN
  902 WRITE (NPRINT,10092) MEMNR
10092 FORMAT (' DB012292 INVALID MEMBERNR.',I10)
      IRC = -2
      RETURN
  903 WRITE (NPRINT,10093)
10093 FORMAT (' DB012293 PDS NOT OPEN')
      IRC = -3
      RETURN
  905 WRITE (NPRINT,10095)
10095 FORMAT (' DB012295 SPACE EXCEEDED')
      IRC = -5
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB0123
      SUBROUTINE DB0123 (MEMNR,MEMSTR,MPOS,LEN,IRC,NFCB,NBRAS)
      COMMON /DC0120/ NPRINT,NVERFY,NDEL
      INTEGER MEMSTR(*),NFCB(64),NBRAS(*)
      IF (NFCB(34).NE.NDEL-1) GOTO 903
      CALL DB012C (NFCB,NBRAS)
      IF (NFCB(38).GT.0) CALL DB0124 (NFCB,NBRAS)
      CALL DB0128 (MEMNR,IDIR,NPOSA,LENA,NFCB,NBRAS)
      IF (LENA.LT.-2) GOTO 902
      IRC = MEMNR
      NF = NFCB(33)
      IF (LENA.EQ.-1) GOTO 100
      IF (LEN-LENA) 200,200,101
  100 IRC = 0
  101 IF (LENA.EQ.-2) IRC = -1
      IF (NVERFY.GT.0) WRITE (NPRINT,10100) MEMNR
10100 FORMAT (' DB012310 MEMBER',I7,' APPENDED, NO FREE AREA FOUND')
      NPOS = NFCB(29)
      IF (NPOS+LEN.GT.NFCB(26)) GOTO 905
      GOTO 500
  200 NPOS = NPOSA
      IF (NVERFY.GT.0) WRITE (NPRINT,10200) MEMNR,NPOS
10200 FORMAT (' DB012320 MEMBER',I7,' REPLACED AT ORIGINAL POS.',I9)
  500 IF (LEN.GT.0) CALL DB0102 (NF,NPOS,MEMSTR,MPOS,LEN,NBRAS)
      N = NPOS - NFCB(28)
      CALL INTCHR(N,4,IDUM,1)
      CALL DB0102 (NF,IDIR,IDUM,0,4,NBRAS)
      CALL INTCHR(LEN,4,IDUM,1)
      CALL DB0102 (NF,IDIR+4,IDUM,1,3,NBRAS)
      IF (NPOS+LEN.GT.NFCB(29)) NFCB(29) = NPOS + LEN
      IF (MEMNR.GT.NFCB(32)) NFCB(32) = MEMNR
      RETURN
  902 WRITE (NPRINT,10092) MEMNR
10092 FORMAT (' DB012392 INVALID MEMBERNR.',I10)
      IRC = -2
      RETURN
  903 WRITE (NPRINT,10093)
10093 FORMAT (' DB012393 PDS NOT OPEN')
      IRC = -3
      RETURN
  905 WRITE (NPRINT,10095)
10095 FORMAT (' DB012395 SPACE EXCEEDED')
      IRC = -5
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB0124
      SUBROUTINE DB0124 (NFCB,NBRAS)
      COMMON /DC0120/ NPRINT,NVERFY,NDEL
      INTEGER NFCB(64),NBRAS(*)
      NF = NFCB(33)
      MEMNR = NFCB(38)
      IF (MEMNR.LE.0) RETURN
      IDIR = (MEMNR-1)*NFCB(30) + NFCB(27)
      NF3928=NFCB(39)-NFCB(28)
      CALL INTCHR(NF3928,4,IDUM,1)
      CALL DB0102 (NF,IDIR,IDUM,0,4,NBRAS)
      LEN = NFCB(40) - NFCB(39)
      IF (NFCB(40).GT.NFCB(29)) NFCB(29) = NFCB(40)
      CALL INTCHR(LEN,4,IDUM,1)
      CALL DB0102 (NF,IDIR+4,IDUM,1,3,NBRAS)
      IF (MEMNR.LE.NFCB(32)) GOTO 100
      NFCB(32) = MEMNR
      IF (NFCB(42) .EQ. MEMNR-1) NFCB(42) = MEMNR
  100 IF (NVERFY.GT.0) WRITE (NPRINT,10100) NFCB(38),NFCB(39),LEN
10100 FORMAT (' DB012410 MEMBER',I7,' CLOSED, START AT',I8,', LENGTH=',
     2  I7)
  500 NFCB(38) = -1
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB0126
      SUBROUTINE DB0126 (MEMNR, NFCB, NBRAS)
      COMMON /DC0120/ NPRINT,NVERFY,NDEL
      INTEGER NFCB(64), NBRAS(*)
      IF (NFCB(34).NE.NDEL-1) GOTO 901
      CALL DB012C (NFCB,NBRAS)
      IF (MEMNR.LE.0.OR.MEMNR.GT.NFCB(32)) GOTO 903
      CALL DB0128 (MEMNR,IDIR,NPOS,LEN,NFCB,NBRAS)
      IF (NPOS.EQ.NDEL) RETURN
      NF = NFCB(33)
      CALL DB0102 (NF,IDIR,NDEL,0,4,NBRAS)
      NZERO = 0
      CALL DB0102 (NF,IDIR+4,NZERO,1,3,NBRAS)
      IF (MEMNR .EQ. NFCB(32)) NFCB(32) = NFCB(32) - 1
      IF (MEMNR .LE. NFCB(42)+1) NFCB(42) = MEMNR - 1
      IF (NVERFY.GT.0) WRITE (NPRINT,10000) MEMNR
10000 FORMAT (' DB012600 MEMBER',I7,' DELETED')
      RETURN
  901 WRITE (NPRINT,10901)
10901 FORMAT (' DB012601 PDS NOT OPEN')
      RETURN
  903 IF (NVERFY.GT.0) WRITE (NPRINT,10903) MEMNR
10903 FORMAT (' DB012603 MEMBER',I7,' NOT FOUND')
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB0128
      SUBROUTINE DB0128 (MEMNR,IDIR,NPOS,LEN,NFCB,NBRAS)
      COMMON /DC0120/ NPRINT,NVERFY,NDEL
      INTEGER NFCB(64),NBRAS(*)
       INTEGER IDUM(1)
      IF (MEMNR.LE.0.OR.MEMNR.GT.NFCB(31)) GOTO 903
      NF = NFCB(33)
      IDIR = (MEMNR-1)*NFCB(30) + NFCB(27)
      LEN = 0
      CALL DB0101 (NF,IDIR,IDUM(1),0,4,NBRAS)
      NPOS = IDUM(1)
      CALL DB0101 (NF,IDIR+4,IDUM(1),1,3,NBRAS)
      LEN = IDUM(1)
      IDUM(1) = NPOS
      CALL CHRINT (IDUM(1),1,4,I)
      NPOS = I
      IDUM(1) = LEN
      CALL CHRINT (IDUM(1),2,3,I)
      LEN = I
      IF (NPOS.EQ.NDEL .OR. LEN.LE.0) LEN = -1
      IF (NPOS.NE.NDEL) NPOS = NPOS + NFCB(28)
      IF (MEMNR.GT.NFCB(32)) LEN = -2
      IF (NVERFY.LT.3) RETURN
      IF (NPOS.EQ.NDEL) WRITE (NPRINT,10010) MEMNR
10010 FORMAT (' DB012810 MEMBER',I7,' DOESN''T EXIST')
      IF (NPOS.NE.NDEL) WRITE (NPRINT,10020) MEMNR,NPOS,LEN,IDIR
10020 FORMAT (' DB012820 MEMBER',I7,' BEGINS AT',I10,', LEN=',I6,
     2   ', DIR=',I7)
      RETURN
  903 LEN = -3
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB012C
      SUBROUTINE DB012C (NFCB,NBRAS)
      COMMON /DC0120/ NPRINT,NVERFY,NDEL
      INTEGER NFCB(64),NBRAS(*)
      NFCB(41) = 2
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD861217--DB0152
      SUBROUTINE DB0152 (NSORT,ENTBUF,NENDIM,NFCB,NBRAS,IRC)
      INTEGER NSORT(*),ENTBUF(*),NFCB(64),NBRAS(*)
      LAST = NFCB(32)
      IF(LAST) 900,320,80
  80  DO 100 I=1,LAST
      CALL DB0128 (I,IDIR,NPOS,LEN,NFCB,NBRAS)
      IF (LEN.GT.NENDIM*4) GOTO 900
      NSORT(2*I-1) = NPOS
      NSORT(2*I) = I
  100 CONTINUE
      L = LAST/2
  110 I = 1
  120 J = I
  130 IF (NSORT (2*J-1) - NSORT(2*(J+L)-1)) 150,150,140
  140 N = NSORT(2*J-1)
      NSORT(2*J-1) = NSORT(2*(J+L)-1)
      NSORT(2*(J+L)-1) = N
      N = NSORT(2*J)
      NSORT(2*J) = NSORT(2*(J+L))
      NSORT(2*(J+L)) = N
      J = J - L
      IF (J.GT.0) GOTO 130
  150 I = I + 1
c      IF (I+L.LE.IDIM) GOTO 120                 !IDIM not defined in original AWH

      IF (I+L.LE.NENDIM) GOTO 120                !Assume IDIM should be NENDIM AWH

      L = L/2
      IF (L.GT.0) GOTO 110
      NFCB(29) = NFCB(28)
      DO 300 I=1,LAST
      NREL = NSORT(2*I)
      CALL DB0121 (NREL,ENTBUF,0,NENDIM*4,LEN,NFCB,NBRAS)
      IF (LEN.LE.0) GOTO 300
      CALL DB0122 (NREL,ENTBUF,0,LEN,IRC,NFCB,NBRAS)
      IF (IRC.LT.-1) RETURN
      CALL DB0124 (NFCB,NBRAS)
  300 CONTINUE
  320 IRC = 0
      RETURN
  900 IRC = -1
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB0212
C
C ---PROGRAM TO CONVERT A CHARACTER STRING FROM SMALL TO CAPITAL
C     LETTERS.
C
C     CALLING SEQUENCE:
C     CALL DB0212(ISTRNG,LENGTH)
C     ISTRNG: INTEGER ARRAY OR VARIABLE; CONTAINS FOUR PACKED
C             CHARACTERS IN EACH ELEMENT.
C     LENGTH: NUMBER OF CHARACTERS TO BE CONVERTED
C
C   +----------------------------------------------------+
C   I  THIS PROGRAM SHOULD BE REPLACED BY A FAST MACHINE I
C   I  ROUTINE IF POSSIBLE                               I
C   +----------------------------------------------------+
C
      SUBROUTINE DB0212 (STRING,L)
      INTEGER STRING(*)
      DATA IH/0/
      DATA KLEINA/129/
      DATA KLEINZ/169/
      DATA IKLGR /64/
      DO 100 J = 1,L
Cmw         CALL COPYCH(STRING,J,1,IH,4)
         CALL COPYCH(STRING,J,1,IH,1)
         IF(IH .GT. KLEINZ) GO TO 100
         IF(IH .LT. KLEINA) GO TO 100
         IH = IH + IKLGR
Cmw         CALL COPYCH(IH,4,1,STRING,J)
         CALL COPYCH(IH,1,1,STRING,J)
100   CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD900130--DB2007
      SUBROUTINE DB2007
      DIMENSION IRM(38)
      COMMON /DC2007/ IRMAX,IRMC(40)
      DATA IRM /3HABC,3HAHT,4HBASI,4HBASM,4HBASO,3HCGD,3HCOA,3HCOR,
     1 4HDEFS,3HDEN,3HDIS,4HDISS,3HEDP,
     2 3HEDS,3HMAG,4HMINR,4HMIXC,3HMOD,
     3 3HNDP,3HNDS,4HNPRM,3HODS,4HPICT,3HPOL,3HPRC,
     4 3HPRE,3HREF,3HSFP,3HSNP,3HSNS,3HTEM,3HTWI,3HXDP,
     5 4HBASD,4HSYMR,3HRVP,3HTHE,3HNMR/
      IRMAX = 38
      DO 100 J = 1,IRMAX
      JUNK = IRM(J)
CC---INTERN WIRD IN EBCDIC GERECHNET
      CALL ASCE (JUNK,1,4)
100   IRMC(J) = JUNK
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD861116--DB2008
      SUBROUTINE DB2008(NRM,IP)
      COMMON /DC2007/ IRMAX,IRMC(40)
      DO 100 J = 1,IRMAX
      IF(NRM .EQ. IRMC(J)) GO TO 200
100   CONTINUE
      IP = 0
      RETURN
200   IP = J
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2011
      SUBROUTINE DB2011
      DIMENSION IREF1(198),IREF2(194),ISYTB(106),MNEM(35)
      DIMENSION IREFP(107)
      COMMON /DC2011/ IELSYM(106),IREFPT(107),MNEMO(35),IREF(392)
CHP8  DATA
C    1ISYTB(  1)/'AC'/,ISYTB( 11)/'BE'/,ISYTB( 21)/'CM'/,
C    2ISYTB(  2)/'AG'/,ISYTB( 12)/'BI'/,ISYTB( 22)/'CO'/,
C    3ISYTB(  3)/'AL'/,ISYTB( 13)/'BK'/,ISYTB( 23)/'CR'/,
C    4ISYTB(  4)/'AM'/,ISYTB( 14)/'BR'/,ISYTB( 24)/'CS'/,
C    5ISYTB(  5)/'AR'/,ISYTB( 15)/'C '/,ISYTB( 25)/'CU'/,
C    6ISYTB(  6)/'AS'/,ISYTB( 16)/'CA'/,ISYTB( 26)/'D '/,
C    7ISYTB(  7)/'AT'/,ISYTB( 17)/'CD'/,ISYTB( 27)/'DY'/,
C    8ISYTB(  8)/'AU'/,ISYTB( 18)/'CE'/,ISYTB( 28)/'ER'/,
C    9ISYTB(  9)/'B '/,ISYTB( 19)/'CF'/,ISYTB( 29)/'ES'/,
C    AISYTB( 10)/'BA'/,ISYTB( 20)/'CL'/,ISYTB( 30)/'EU'/
Cmw      DATAISYTB(1)/Z'C1C34040'/,ISYTB(11)/Z'C2C54040'/,ISYTB(21)/Z'C3D44
Cmw     $040'/,ISYTB(2)/Z'C1C74040'/,ISYTB(12)/Z'C2C94040'/,ISYTB(22)/Z'C3D
Cmw     $64040'/,ISYTB(3)/Z'C1D34040'/,ISYTB(13)/Z'C2D24040'/,ISYTB(23)/Z'C
Cmw     $3D94040'/,ISYTB(4)/Z'C1D44040'/,ISYTB(14)/Z'C2D94040'/,ISYTB(24)/Z
Cmw     $'C3E24040'/,ISYTB(5)/Z'C1D94040'/,ISYTB(15)/Z'C3404040'/,ISYTB(25)
Cmw     $/Z'C3E44040'/,ISYTB(6)/Z'C1E24040'/,ISYTB(16)/Z'C3C14040'/,ISYTB(2
Cmw     $6)/Z'C4404040'/,ISYTB(7)/Z'C1E34040'/,ISYTB(17)/Z'C3C44040'/,ISYTB
Cmw     $(27)/Z'C4E84040'/,ISYTB(8)/Z'C1E44040'/,ISYTB(18)/Z'C3C54040'/,ISY
Cmw     $TB(28)/Z'C5D94040'/,ISYTB(9)/Z'C2404040'/,ISYTB(19)/Z'C3C64040'/,I
Cmw     $SYTB(29)/Z'C5E24040'/,ISYTB(10)/Z'C2C14040'/,ISYTB(20)/Z'C3D34040'
Cmw     $/,ISYTB(30)/Z'C5E44040'/
      DATAISYTB(1)/Z'4040C3C1'/,ISYTB(11)/Z'4040C5C2'/,ISYTB(21)/Z'4040D
     $4C3'/,ISYTB(2)/Z'4040C7C1'/,ISYTB(12)/Z'4040C9C2'/,ISYTB(22)/Z'404
     $0D6C3'/,ISYTB(3)/Z'4040D3C1'/,ISYTB(13)/Z'4040D2C2'/,ISYTB(23)/Z'4
     $040D9C3'/,ISYTB(4)/Z'4040D4C1'/,ISYTB(14)/Z'4040D9C2'/,ISYTB(24)/Z
     $'4040E2C3'/,ISYTB(5)/Z'4040D9C1'/,ISYTB(15)/Z'404040C3'/,ISYTB(25)
     $/Z'4040E4C3'/,ISYTB(6)/Z'4040E2C1'/,ISYTB(16)/Z'4040C1C3'/,ISYTB(2
     $6)/Z'404040C4'/,ISYTB(7)/Z'4040E3C1'/,ISYTB(17)/Z'4040C4C3'/,ISYTB
     $(27)/Z'4040E8C4'/,ISYTB(8)/Z'4040E4C1'/,ISYTB(18)/Z'4040C5C3'/,ISY
     $TB(28)/Z'4040D9C5'/,ISYTB(9)/Z'404040C2'/,ISYTB(19)/Z'4040C6C3'/,I
     $SYTB(29)/Z'4040E2C5'/,ISYTB(10)/Z'4040C1C2'/,ISYTB(20)/Z'4040D3C3'
     $/,ISYTB(30)/Z'4040E4C5'/
CHP8  DATA
C    1ISYTB( 31)/'F '/,ISYTB( 41)/'HG'/,ISYTB( 51)/'LU'/,
C    2ISYTB( 32)/'FE'/,ISYTB( 42)/'HO'/,ISYTB( 52)/'LW'/,
C    3ISYTB( 33)/'FM'/,ISYTB( 43)/'I '/,ISYTB( 53)/'MD'/,
C    4ISYTB( 34)/'FR'/,ISYTB( 44)/'IN'/,ISYTB( 54)/'MG'/,
C    5ISYTB( 35)/'GA'/,ISYTB( 45)/'IR'/,ISYTB( 55)/'MN'/,
C    6ISYTB( 36)/'GD'/,ISYTB( 46)/'K '/,ISYTB( 56)/'MO'/,
C    7ISYTB( 37)/'GE'/,ISYTB( 47)/'KR'/,ISYTB( 57)/'N '/,
C    8ISYTB( 38)/'H '/,ISYTB( 48)/'KU'/,ISYTB( 58)/'NA'/,
C    9ISYTB( 39)/'HE'/,ISYTB( 49)/'LA'/,ISYTB( 59)/'NB'/,
C    AISYTB( 40)/'HF'/,ISYTB( 50)/'LI'/,ISYTB( 60)/'ND'/
Cmw      DATAISYTB(31)/Z'C6404040'/,ISYTB(41)/Z'C8C74040'/,ISYTB(51)/Z'D3E4
Cmw     $4040'/,ISYTB(32)/Z'C6C54040'/,ISYTB(42)/Z'C8D64040'/,ISYTB(52)/Z'D
Cmw     $3E64040'/,ISYTB(33)/Z'C6D44040'/,ISYTB(43)/Z'C9404040'/,ISYTB(53)/
Cmw     $Z'D4C44040'/,ISYTB(34)/Z'C6D94040'/,ISYTB(44)/Z'C9D54040'/,ISYTB(5
Cmw     $4)/Z'D4C74040'/,ISYTB(35)/Z'C7C14040'/,ISYTB(45)/Z'C9D94040'/,ISYT
Cmw     $B(55)/Z'D4D54040'/,ISYTB(36)/Z'C7C44040'/,ISYTB(46)/Z'D2404040'/,I
Cmw     $SYTB(56)/Z'D4D64040'/,ISYTB(37)/Z'C7C54040'/,ISYTB(47)/Z'D2D94040'
Cmw     $/,ISYTB(57)/Z'D5404040'/,ISYTB(38)/Z'C8404040'/,ISYTB(48)/Z'D2E440
Cmw     $40'/,ISYTB(58)/Z'D5C14040'/,ISYTB(39)/Z'C8C54040'/,ISYTB(49)/Z'D3C
Cmw     $14040'/,ISYTB(59)/Z'D5C24040'/,ISYTB(40)/Z'C8C64040'/,ISYTB(50)/Z'
Cmw     $D3C94040'/,ISYTB(60)/Z'D5C44040'/
      DATAISYTB(31)/Z'404040C6'/,ISYTB(41)/Z'4040C7C8'/,ISYTB(51)/Z'4040
     $E4D3'/,ISYTB(32)/Z'4040C5C6'/,ISYTB(42)/Z'4040D6C8'/,ISYTB(52)/Z'4
     $040E6D3'/,ISYTB(33)/Z'4040D4C6'/,ISYTB(43)/Z'404040C9'/,ISYTB(53)/
     $Z'4040C4D4'/,ISYTB(34)/Z'4040D9C6'/,ISYTB(44)/Z'4040D5C9'/,ISYTB(5
     $4)/Z'4040C7D4'/,ISYTB(35)/Z'4040C1C7'/,ISYTB(45)/Z'4040D9C9'/,ISYT
     $B(55)/Z'4040D5D4'/,ISYTB(36)/Z'4040C4C7'/,ISYTB(46)/Z'404040D2'/,I
     $SYTB(56)/Z'4040D6D4'/,ISYTB(37)/Z'4040C5C7'/,ISYTB(47)/Z'4040D9D2'
     $/,ISYTB(57)/Z'404040D5'/,ISYTB(38)/Z'404040C8'/,ISYTB(48)/Z'4040E4
     $D2'/,ISYTB(58)/Z'4040C1D5'/,ISYTB(39)/Z'4040C5C8'/,ISYTB(49)/Z'404
     $0C1D3'/,ISYTB(59)/Z'4040C2D5'/,ISYTB(40)/Z'4040C6C8'/,ISYTB(50)/Z'
     $4040C9D3'/,ISYTB(60)/Z'4040C4D5'/
CHP8  DATA
C    1ISYTB( 61)/'NE'/,ISYTB( 71)/'PM'/,ISYTB( 81)/'RU'/,
C    2ISYTB( 62)/'NI'/,ISYTB( 72)/'PO'/,ISYTB( 82)/'S '/,
C    3ISYTB( 63)/'NO'/,ISYTB( 73)/'PR'/,ISYTB( 83)/'SB'/,
C    4ISYTB( 64)/'NP'/,ISYTB( 74)/'PT'/,ISYTB( 84)/'SC'/,
C    5ISYTB( 65)/'O '/,ISYTB( 75)/'PU'/,ISYTB( 85)/'SE'/,
C    6ISYTB( 66)/'OS'/,ISYTB( 76)/'RA'/,ISYTB( 86)/'SI'/,
C    7ISYTB( 67)/'P '/,ISYTB( 77)/'RB'/,ISYTB( 87)/'SM'/,
C    8ISYTB( 68)/'PA'/,ISYTB( 78)/'RE'/,ISYTB( 88)/'SN'/,
C    9ISYTB( 69)/'PB'/,ISYTB( 79)/'RH'/,ISYTB( 89)/'SR'/,
C    AISYTB( 70)/'PD'/,ISYTB( 80)/'RN'/,ISYTB( 90)/'T '/
Cmw      DATAISYTB(61)/Z'D5C54040'/,ISYTB(71)/Z'D7D44040'/,ISYTB(81)/Z'D9E4
Cmw     $4040'/,ISYTB(62)/Z'D5C94040'/,ISYTB(72)/Z'D7D64040'/,ISYTB(82)/Z'E
Cmw     $2404040'/,ISYTB(63)/Z'D5D64040'/,ISYTB(73)/Z'D7D94040'/,ISYTB(83)/
Cmw     $Z'E2C24040'/,ISYTB(64)/Z'D5D74040'/,ISYTB(74)/Z'D7E34040'/,ISYTB(8
Cmw     $4)/Z'E2C34040'/,ISYTB(65)/Z'D6404040'/,ISYTB(75)/Z'D7E44040'/,ISYT
Cmw     $B(85)/Z'E2C54040'/,ISYTB(66)/Z'D6E24040'/,ISYTB(76)/Z'D9C14040'/,I
Cmw     $SYTB(86)/Z'E2C94040'/,ISYTB(67)/Z'D7404040'/,ISYTB(77)/Z'D9C24040'
Cmw     $/,ISYTB(87)/Z'E2D44040'/,ISYTB(68)/Z'D7C14040'/,ISYTB(78)/Z'D9C540
Cmw     $40'/,ISYTB(88)/Z'E2D54040'/,ISYTB(69)/Z'D7C24040'/,ISYTB(79)/Z'D9C
Cmw     $84040'/,ISYTB(89)/Z'E2D94040'/,ISYTB(70)/Z'D7C44040'/,ISYTB(80)/Z'
Cmw     $D9D54040'/,ISYTB(90)/Z'E3404040'/
      DATAISYTB(61)/Z'4040C5D5'/,ISYTB(71)/Z'4040D4D7'/,ISYTB(81)/Z'4040
     $E4D9'/,ISYTB(62)/Z'4040C9D5'/,ISYTB(72)/Z'4040D6D7'/,ISYTB(82)/Z'4
     $04040E2'/,ISYTB(63)/Z'4040D6D5'/,ISYTB(73)/Z'4040D9D7'/,ISYTB(83)/
     $Z'4040C2E2'/,ISYTB(64)/Z'4040D7D5'/,ISYTB(74)/Z'4040E3D7'/,ISYTB(8
     $4)/Z'4040C3E2'/,ISYTB(65)/Z'404040D6'/,ISYTB(75)/Z'4040E4D7'/,ISYT
     $B(85)/Z'4040C5E2'/,ISYTB(66)/Z'4040E2D6'/,ISYTB(76)/Z'4040C1D9'/,I
     $SYTB(86)/Z'4040C9E2'/,ISYTB(67)/Z'404040D7'/,ISYTB(77)/Z'4040C2D9'
     $/,ISYTB(87)/Z'4040D4E2'/,ISYTB(68)/Z'4040C1D7'/,ISYTB(78)/Z'4040C5
     $D9'/,ISYTB(88)/Z'4040D5E2'/,ISYTB(69)/Z'4040C2D7'/,ISYTB(79)/Z'404
     $0C8D9'/,ISYTB(89)/Z'4040D9E2'/,ISYTB(70)/Z'4040C4D7'/,ISYTB(80)/Z'
     $4040D5D9'/,ISYTB(90)/Z'404040E3'/
CHP8  DATA
C    1ISYTB( 91)/'TA'/,ISYTB(101)/'W '/,
C    2ISYTB( 92)/'TB'/,ISYTB(102)/'XE'/,
C    3ISYTB( 93)/'TC'/,ISYTB(103)/'Y '/,
C    4ISYTB( 94)/'TE'/,ISYTB(104)/'YB'/,
C    5ISYTB( 95)/'TH'/,ISYTB(105)/'ZN'/,
C    6ISYTB( 96)/'TI'/,ISYTB(106)/'ZR'/,
C    7ISYTB( 97)/'TL'/,
C    8ISYTB( 98)/'TM'/,
C    9ISYTB( 99)/'U '/,
C    AISYTB(100)/'V '/
Cmw      DATAISYTB(91)/Z'E3C14040'/,ISYTB(101)/Z'E6404040'/,ISYTB(92)/Z'E3C
Cmw     $24040'/,ISYTB(102)/Z'E7C54040'/,ISYTB(93)/Z'E3C34040'/,ISYTB(103)/
Cmw     $Z'E8404040'/,ISYTB(94)/Z'E3C54040'/,ISYTB(104)/Z'E8C24040'/,ISYTB(
Cmw     $95)/Z'E3C84040'/,ISYTB(105)/Z'E9D54040'/,ISYTB(96)/Z'E3C94040'/,IS
Cmw     $YTB(106)/Z'E9D94040'/,ISYTB(97)/Z'E3D34040'/,ISYTB(98)/Z'E3D44040'
Cmw     $/,ISYTB(99)/Z'E4404040'/,ISYTB(100)/Z'E5404040'/
      DATAISYTB(91)/Z'4040C1E3'/,ISYTB(101)/Z'404040E6'/,ISYTB(92)/Z'404
     $0C2E3'/,ISYTB(102)/Z'4040C5E7'/,ISYTB(93)/Z'4040C3E3'/,ISYTB(103)/
     $Z'404040E8'/,ISYTB(94)/Z'4040C5E3'/,ISYTB(104)/Z'4040C2E8'/,ISYTB(
     $95)/Z'4040C8E3'/,ISYTB(105)/Z'4040D5E9'/,ISYTB(96)/Z'4040C9E3'/,IS
     $YTB(106)/Z'4040D9E9'/,ISYTB(97)/Z'4040D3E3'/,ISYTB(98)/Z'4040D4E3'
     $/,ISYTB(99)/Z'404040E4'/,ISYTB(100)/Z'404040E5'/
      DATA IREF1/16,23,25,35, 9,16,25,33, 5,16,31, 1,16,26,35, 13,19,22,
     1 31, 18,19,32, 11,12,19,34, 9,16,25,34, 5,19,30, 2,4,16,34, 4,16,
     2 30, 16,18,34, 1,16,26,35, 11,12,19,32, 6,19,30, 2,4,16,32, 16,25,
     3 28,33, 14,16,23,34, 1,16,26,35, 11,12,19,31, 1,16,26,35, 10,16,
     4 25,32, 8,16,25,32, 3,15,16,34, 9,16,25,32, 19,29, 14,16,34, 14,
     5 16,34, 1,16,26,35, 14,16,34, 11,12,19,30, 10,16,25,32, 1,16,26,
     6 35, 3,15,16,35, 5,16,32, 14,16,34, 6,16,32, 19,29, 13,19,22,29,
     7 16,24,25,34, 16,25,28,34, 14,16,34, 11,12,19,33, 5,16,33, 10,16,
     8 21,25,34, 3,15,16,32, 13,19,22,32, 16,24,25,26,35, 16,23,25,34,
     9 3,15,16,30, 14,16,34, 1,16,26,35, 1,16,26,35, 4,16,31/
      DATA IREF2/16,17,25,32, 8,16,25,33, 18,19,30, 3,15,16,31, 16,25,
     1 27,33, 14,16,34, 13,19,22,30, 10,16,25,32, 1,16,26,35, 1,16,26,
     2 35, 7,19,20,30, 10,16,21,25,34, 18,19,31, 1,16,35, 6,16,34,
     3 10,16,21,25,33, 14,16,34, 7,16,20,34, 14,16,34, 10,16,21,25,34,
     4 1,16,26,35, 2,4,16,35, 3,15,16,33, 16,17,25,34, 10,16,21,25,33,
     5 13,19,22,34, 10,16,21,25,33, 7,19,20,31, 16,18,33, 16,23,25,32,
     6 7,19,20,32, 6,19,31, 14,16,34, 6,16,33, 2,4,16,33,
     7 19,29, 16,25,27,34,
     8 14,16,34, 16,17,25,33, 7,19,20,33, 1,16,35, 16,24,25,32, 5,16,34,
     9 14,16,34, 1,16,35, 16,25,27,32, 8,16,25,34, 13,19,22,33, 16,23,
     A 25,33, 14,16,34, 16,25,28,32, 16,24,25,33/
      DATA IREFP/1, 5, 9, 12,16,20,23,27,31,34,38,41,44,48,52,55,59,
     1 63,67,71,75,79,83,87,91,95,97,100,103,107,110,114,118,122,126,
     2 129,132,135,137,141,145,149,152,156,159,164,168,172,177,181,185,
     3 188,192,196,199,203,207,210,214,218,221,225,229,233,237,241,246,
     4 249,252,255,260,263,267,270,275,279,283,287,291,296,300,305,309,
     5 312,316,320,323,326,329,333,335,339,342,346,350,353,357,360,363,
     6 366,370,374,378,382,385,389,393/
CHP8  DATA MNEM( 1) /'ACT'/,MNEM(11) /'FG '/
Cmw      DATAMNEM(1)/Z'C1C3E340'/,MNEM(11)/Z'C6C74040'/
      DATAMNEM(1)/Z'40E3C3C1'/,MNEM(11)/Z'4040C7C6'/
CHP8  DATA MNEM( 2) /'ALE'/,MNEM(12) /'HAL'/
Cmw      DATAMNEM(2)/Z'C1D3C540'/,MNEM(12)/Z'C8C1D340'/
      DATAMNEM(2)/Z'40C5D3C1'/,MNEM(12)/Z'40D3C1C8'/
CHP8  DATA MNEM( 3) /'ALK'/,MNEM(13) /'HEG'/
Cmw      DATAMNEM(3)/Z'C1D3D240'/,MNEM(13)/Z'C8C5C740'/
      DATAMNEM(3)/Z'40D2D3C1'/,MNEM(13)/Z'40C7C5C8'/
CHP8  DATA MNEM( 4) /'BEG'/,MNEM(14) /'LAN'/
Cmw      DATAMNEM(4)/Z'C2C5C740'/,MNEM(14)/Z'D3C1D540'/
      DATAMNEM(4)/Z'40C7C5C2'/,MNEM(14)/Z'40D5C1D3'/
CHP8  DATA MNEM( 5) /'BG '/,MNEM(15) /'LIG'/
Cmw      DATAMNEM(5)/Z'C2C74040'/,MNEM(15)/Z'D3C9C740'/
      DATAMNEM(5)/Z'4040C7C2'/,MNEM(15)/Z'40C7C9D3'/
CHP8  DATA MNEM( 6) /'CG '/,MNEM(16) /'MET'/
Cmw      DATAMNEM(6)/Z'C3C74040'/,MNEM(16)/Z'D4C5E340'/
      DATAMNEM(6)/Z'4040C7C3'/,MNEM(16)/Z'40E3C5D4'/
CHP8  DATA MNEM( 7) /'CHA'/,MNEM(17) /'MNG'/
Cmw      DATAMNEM(7)/Z'C3C8C140'/,MNEM(17)/Z'D4D5C740'/
      DATAMNEM(7)/Z'40C1C8C3'/,MNEM(17)/Z'40C7D5D4'/
CHP8  DATA MNEM( 8) /'CRG'/,MNEM(18) /'NG '/
Cmw      DATAMNEM(8)/Z'C3D9C740'/,MNEM(18)/Z'D5C74040'/
      DATAMNEM(8)/Z'40C7D9C3'/,MNEM(18)/Z'4040C7D5'/
CHP8  DATA MNEM( 9) /'CUG'/,MNEM(19) /'NOM'/
Cmw      DATAMNEM(9)/Z'C3E4C740'/,MNEM(19)/Z'D5D6D440'/
      DATAMNEM(9)/Z'40C7E4C3'/,MNEM(19)/Z'40D4D6D5'/
CHP8  DATA MNEM(10) /'FEG'/,MNEM(20) /'OG '/
C
Cmw      DATAMNEM(10)/Z'C6C5C740'/,MNEM(20)/Z'D6C74040'/
      DATAMNEM(10)/Z'40C7C5C6'/,MNEM(20)/Z'4040C7D6'/
CHP8  DATA MNEM(21) /'PTM'/,MNEM(31) /'3PE'/
Cmw      DATAMNEM(21)/Z'D7E3D440'/,MNEM(31)/Z'F3D7C540'/
      DATAMNEM(21)/Z'40D4E3D7'/,MNEM(31)/Z'40C5D7F3'/
CHP8  DATA MNEM(22) /'RGA'/,MNEM(32) /'4PE'/
Cmw      DATAMNEM(22)/Z'D9C7C140'/,MNEM(32)/Z'F4D7C540'/
      DATAMNEM(22)/Z'40C1C7D9'/,MNEM(32)/Z'40C5D7F4'/
CHP8  DATA MNEM(23) /'SCG'/,MNEM(33) /'5PE'/
Cmw      DATAMNEM(23)/Z'E2C3C740'/,MNEM(33)/Z'F5D7C540'/
      DATAMNEM(23)/Z'40C7C3E2'/,MNEM(33)/Z'40C5D7F5'/
CHP8  DATA MNEM(24) /'TIG'/,MNEM(34) /'6PE'/
Cmw      DATAMNEM(24)/Z'E3C9C740'/,MNEM(34)/Z'F6D7C540'/
      DATAMNEM(24)/Z'40C7C9E3'/,MNEM(34)/Z'40C5D7F6'/
CHP8  DATA MNEM(25) /'TRM'/,MNEM(35) /'7PE'/
Cmw      DATAMNEM(25)/Z'E3D9D440'/,MNEM(35)/Z'F7D7C540'/
      DATAMNEM(25)/Z'40D4D9E3'/,MNEM(35)/Z'40C5D7F7'/
CHP8  DATA MNEM(26) /'TRU'/
Cmw      DATAMNEM(26)/Z'E3D9E440'/
      DATAMNEM(26)/Z'40E4D9E3'/
CHP8  DATA MNEM(27) /'VG '/
Cmw      DATAMNEM(27)/Z'E5C74040'/
      DATAMNEM(27)/Z'4040C7E5'/
CHP8  DATA MNEM(28) /'ZNG'/
Cmw      DATAMNEM(28)/Z'E9D5C740'/
      DATAMNEM(28)/Z'40C7D5E9'/
CHP8  DATA MNEM(29) /'1PE'/
Cmw      DATAMNEM(29)/Z'F1D7C540'/
      DATAMNEM(29)/Z'40C5D7F1'/
CHP8  DATA MNEM(30) /'2PE'/
Cmw      DATAMNEM(30)/Z'F2D7C540'/
      DATAMNEM(30)/Z'40C5D7F2'/
      DO 10 I=1,198
   10 IREF(I)=IREF1(I)
      DO 20 I=1,194
   20 IREF(I+198)=IREF2(I)
      DO 30 I=1,35
   30 MNEMO(I)=MNEM(I)
      DO 40 I=1,106
      IELSYM(I)=ISYTB(I)
   40 IREFPT(I)=IREFP(I)
      IREFPT(107)=IREFP(107)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD861116--DB2012
      SUBROUTINE DB2012 (ISYM,LEN,LIST)
      DIMENSION LIST(*),ISYM(*)
      COMMON /DC2011/ IELSYM(106),IREFPT(107),MNEMO(35),IREF(392)
      LEN=1
      NV=1
      NH=106
      NM=65
      GO TO 25
  10  NV=NM+1
  20  IF (NV .GT. NH) GO TO 30
      NM=(NV+NH)/2
  25  IF (LCOMPS(ISYM,1,4,IELSYM(NM),1)) 27,40,10
  27  NH=NM-1
      GO TO 20
  30  DO 31 I=1,35
      IF (ISYM(1) .EQ. MNEMO(I)) GO TO 32
  31  CONTINUE
      I=-130
  32  LIST(1)=I+130
      GO TO 999
  40  LIST(1)=NM
      NV=IREFPT(NM)
      NH=IREFPT(NM+1)-1
      DO 50 I=NV,NH
      LEN=LEN+1
  50  LIST(LEN)=IREF(I) + 130
 999  CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850905--DB2013
      SUBROUTINE DB2013 (ISYM,NSYM)
      COMMON /DC2011/ IELSYM(106),IREFPT(107),MNEMO(35),IREF(392)
CHP8  DATA IFRAG/'?'/
Cmw      DATAIFRAG/Z'6F404040'/
      DATAIFRAG/Z'4040406F'/
      IF (ISYM .GT. 130) GO TO 10
      IF (ISYM .GT. 106) GO TO 15
      NSYM=IELSYM(ISYM)
      GO TO 999
   10 IF(ISYM .LE. 165) GO TO 20
   15 NSYM = IFRAG
      GO TO 999
   20 NSYM=MNEMO(ISYM-130)
 999  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2019
      SUBROUTINE DB2019(IREM,ISYM)
      COMMON /DC2007/ IRMAX,IRMC(40)
CHP8  DATA ISTERN /'****'/
      DATAISTERN/Z'5C5C5C5C'/
      IF(IREM .LT. 1) GO TO 100
      IF(IREM .GT. IRMAX) GO TO 100
      ISYM = IRMC(IREM)
      RETURN
100   ISYM = ISTERN
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880527--DB2201
      SUBROUTINE DB2201(IAR,IBACK,IRC)
C
C ---MAIN ROUTINE OF ICSD ACCESS SYSTEM
C
      INTEGER DB2210
C
C ***********************************
C ---DECLARATION OF MAIN WORK ARRAY
C    (CHANGE  DATA MNARMX/..../ TOO!)
C    MNAR AND ARMN ARE EQUIVALENCED.
C ***********************************
      INTEGER   MNAR(40000)
      REAL      ARMN(40000)
C
      COMMON /SETUP/  KBASES,KDPROP(60)
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2206/ DUM1(64),ITABCB(64),DUM2(64)
      COMMON /DC2337/ IELORD(20),MXLORD,IELOFL
      COMMON /DC0100/ NREC,NFLAG,NSEQ,NFILE,NTEXT,NSF,NSFPNT,
     2       NBLSIZ,NWORDS,MAXBLK,NPRINT,NVERFY,NBUFST,IOPEN,IWRITE,
     3       NPCNT,ISTOPF,NRDCNT,NWRCNT
      COMMON /KPFCOM/ KPCOM(50)
      DIMENSION IAR(*),ID(8),IDZ(8),IUSRN(4)
      DIMENSION ICATA(30)
C ---NDPROP IS THE PROPERTIES' ARRAY. IT SHOULD BE DIMENSIONED
C     DIMENSION NDPROP(LPROPR*NBASES)
      DIMENSION NDPROP(60)
C
      EQUIVALENCE (MNAR(1),ARMN(1))
C
C ********************************
C ---LENGTH OF THE MAIN WORK ARRAY
C ********************************
      DATA MNARMX/40000/
C
C ********************************
C ---MAXIMUM NUMBER OF I/O BUFFERS
C ********************************
      DATA NBFMAX/12/
C
      DATA NBFLEN/760/, NBFMIN/4/
      DATA MAXCAT/30/
C
C *********************************************************************
C ---DECLARATION OF RANDOM FILES (TABLES FILE,
C     SCRATCH FILE)
C *********************************************************************
      DATA ITABL/ 3/, ISCR/10/
C
C *******************************************************************
C ---SCRATCH FILE SIZE (NUMBER OF BLOCKS WITH 760 WORDS = 3040 BYTES)
C *******************************************************************
      DATA NSCRBL/25/
C
C **************************************************************
C ---DECLARATION OF UNIT FOR FORMATTED, MACHINE READABLE OUTPUT.
C     (LOGICAL) RECORD LENGTH IS 80. SHOULD BE -1, IF ISPECU=0.
C **************************************************************
      DATA IFRMFL/ 4/
C
C ******************************************************************
C ---CONSTANTS TO BE SET AT SYSTEM IMPLEMENTATION TIME:
C     MOREDF - NUMBER OF LINES PRINTED UNTIL DISPLAY CAN BE STOPPED
C     IHDEF 0/1 - HELP INFO IN GERMAN/ENGLISH (DEFAULT)
C     MXSCAN - NUMBER OF ENTRIES WHICH ARE SCANNED IN THE STRING
C              COMMAND UNTIL SCAN CAN BE INTERRUPTED
C     MXDIST - NUMBER OF ENTRIES FOR WHICH DISTANCE CALCULATION IS
C              PERFORMED (IN DIST COMMAND WITH SELECT OPTION) UNTIL
C              COMMAND CAN BE INTERRUPTED
C     ISPECU 0/1 - FORMATTED OUTPUT ON UNIT IFRMFL IS NOT/IS ALLOWED
C ******************************************************************
C
      DATA MOREDF/20/, IHDEF/0/, MXSCAN/500/, MXDIST/50/,
     1ISPECU/1/
C
C ******************************************************************
C ---FORTRAN MAY  W R I T E  ONLY TO THE PORTS IWRUN1...IWRUN2
      DATA IWRUN1/40/, IWRUN2/49/
C ******************************************************************
C
C       ****************************************************
C       ****************************************************
C       **                                                **
C       **     DECLARATION OF THE DATABASE PROPERTIES     **
C       **                                                **
C       ****************************************************
C       ****************************************************
C
C ---NUMBER OF DATABASES WHICH CAN BE RETRIEVED SIMULTANOUSLY
C     IN ONE SINGLE SESSION
      DATA NBASES /1/
C
C ---NUMBER OF WORDS REQUIRED FOR ONE DATABASE:
      DATA LPROPR/6/
C
C
C ---NOW SPECIFY THE PROPERTIES OF EACH DATABASE IN THE
C     FOLLOWING WAY:
C     NDPROP(1) - FORTRAN PORT NUMBER OF THE FIRST DATABASE
C     NDPROP(2) - FORTRAN PORT NUMBER OF THE ASSOCIATED INDEX FILE
C     NDPROP(3) - AUTHORITY TEST BIT. ICSD=1  CCDF=8
C                 CRYSTAL DATA=4  MDF=2
C     NDPROP(4) - TYPE OF DATABASE: 1=ICSD  2=CCDF  3=MDF
C                 4=CRYSTAL DATA
C     NDPROP(5),(6) - PASSWORD (BLANK: NO PASSWORD)
C     NDPROP(7) - FORTRAN PORT NUMBER OF THE SECOND DATABASE
C     ETC.
C
CHP8  DATA
C    1 NDPROP( 1)/ 1/, NDPROP( 2)/ 2/, NDPROP( 3)/1/,
C    2 NDPROP( 4)/ 1/, NDPROP( 5),NDPROP( 6)/'    ','    '/
C
C ********************************************************************
C
      DATANDPROP(1)/1/,NDPROP(2)/2/,NDPROP(3)/1/,NDPROP(4)/1/,NDPROP(5),
     $NDPROP(6)/Z'40404040',Z'40404040'/
CHP8  DATA IREL1/0/, IREL2/0/, ICELE/'ELE'/, ICLAST/'LAST'/
Cmw      DATAIREL1/0/,IREL2/0/,ICELE/Z'C5D3C540'/,ICLAST/Z'D3C1E2E3'/
      DATAIREL1/0/,IREL2/0/,ICELE/Z'40C5D3C5'/,ICLAST/Z'E3E2C1D3'/
CHP8  DATA IUSRN/'USRN','USR ','US  ','U   '/
Cmw      DATAIUSRN/Z'E4E2D9D5',Z'E4E2D940',Z'E4E24040',Z'E4404040'/
      DATAIUSRN/Z'D5D9E2E4',Z'40D9E2E4',Z'4040E2E4',Z'404040E4'/
      DATA NDSPL/0/, NRDCM/0/
      DATA LENDKB/132/, LENDKH/5/
      DATA INT1,INT2,INT3,INT4,INT5,INT6,INT7,INT8,INT9,INT10,INT11
     1/     1,    2,   3,   4,   5,   6,   7,   8,   9,   10,   11/
      DATA INT12,INT13,INT14,INT15,INT16
     1/      12,   13,   14,   15,   16/
      IOP1 = IAR(1)
      IF(IOP1 .LE. 0) GO TO 9160
      IOP2 = IAR(INT2)
      IF(IOP2 .LE. 0) GO TO 9160
      IF(IOP1 .GT. 6) GO TO 9160
      IARG1 = IAR(INT3)
      IARG2 = IAR(INT4)
      IFLAG(32) = 0
      IFLAG(33) = NDSPL
      GO TO(1840,2600,1000,3400,3760,4400), IOP1
 1000 IF(IOP2 .GT. 7) GO TO 9160
      GO TO (1040,1200,1720,1760,1800,1822,1825), IOP2
 1040 NINPT = IARG1
      NDSPL = IARG2
      NPRTR = IAR(INT5)
      IFLAG(16) = NDSPL
      IFLAG(17) = MXSCAN
      IFLAG(18) = IFRMFL
      IFLAG(21) = ITABL
      IFLAG(23) = -1
      DO 1060 J = 1,50
1060  KPCOM(J) = 0
      IFLAG(25) = NINPT
      IFLAG(26) = MXDIST
      IFLAG(27) = IFRMFL
      IFLAG(28) = IHDEF
      IFLAG(29) = 0
      IFLAG(37) = 0
      IFLAG(41) = 0
      IFLAG(43) = 0
      IFLAG(45) = IWRUN1
      IFLAG(46) = IWRUN2
      IFLAG(48) = 0
C
C ---DATABASE DEFINITIONS LOADED FROM THE SETUP FILE?
      IF (IFLAG(47) .NE. 0) THEN
         NBASES = KBASES
         DO 1070 J = 1,KBASES*LPROPR
1070     NDPROP(J) = KDPROP(J)
      END IF
      IFLAG(24) = NBASES
C
C ***************************************************
C ---RESERVE 60% OF MAIN ARRAY FOR I/O BUFFERS.
C     BUT: MIN=4 (SHOULD NOT BE CHANGED), MAX=NBFMAX.
C ***************************************************
 1080 IBUFNO = FLOAT(MNARMX) * 0.6 / FLOAT(NBFLEN+4)
      IF(IBUFNO .LT. 1) GO TO 9040
      IF(IBUFNO .GE. NBFMIN) GO TO 1160
      WRITE(NDSPL,1120)
 1120 FORMAT(' DB2201 - MAIN WORK ARRAY IS RATHER SMALL')
 1160 IBUFNO = MIN0(NBFMAX,IBUFNO)
      GO TO 1280
 1200 CALL DB0105(MNAR(NBRADR))
      IBUFNO = IARG1
      IF(IBUFNO .LE. 0) GO TO 1080
      IF(IBUFNO*(NBFLEN+4) + 1000 .LT. MNARMX) GO TO 1280
      IBUFNO = FLOAT(MNARMX-1000)/FLOAT(NBFLEN+4)
      WRITE(NDSPL,1240) IBUFNO
 1240 FORMAT(' BUFFER NUMBER SET TO',I4)
 1280 DO 1320 J = 1,15
 1320 IFLAG(J) = 0
      IFLAG(39) = 0
      CALL DB2230(MNAR,MNARMX)
      CALL DB2231(MNAR,IBUFNO*(NBFLEN+4),NBRADR)
      IF(NBRADR .LE. 0) GO TO 9080
      CALL DB0100(MNAR(NBRADR),NBRADR+IBUFNO*(NBFLEN+4)-1,NBFLEN,
     1IBUFNO,NDSPL,0,0)
      CALL DB2231(MNAR,LENDKH+NBASES*LENDKB,IDBCB)
      IF(IDBCB .LE. 0) GO TO 9080
      IFLAG(40) = IDBCB
      MNAR(IDBCB) = LENDKB
      MNAR(IDBCB+1) = LENDKH
      MNAR(IDBCB+2) = NBASES
      MNAR(IDBCB+3) = 0
      MNAR(IDBCB+4) = LPROPR
      IELOFL = 0
      MXLORD = 20
      IF(IFLAG(37) .EQ. 0) CALL CLEAR
      WRITE(NDSPL,1400)
 1400 FORMAT(/,
     1' ***********   Crystal Structure Information System',/,
     2' * CRYSTIN *   (Release 2.42/Nov. 87)',/,
     3' ***********   Written by Hundt & Sievers (University of Bonn)',
     4 /)
      DO 1640 J = 1,MAXCAT
 1640 ICATA(J) = 0
      LAST = 0
      CALL DB2011
      CALL DB2007
      CALL DB0120(ITABL,NDSPL,0,ITABCB,MNAR(NBRADR))
      CALL DB0128(92,IDIR,IFLAG(30),LEN,ITABCB,MNAR(NBRADR))
      IF(LEN .LE. 0) GO TO 8960
      CALL DB0128(93,IDIR,IFLAG(42),LEN,ITABCB,MNAR(NBRADR))
      IF(LEN .LE. 0) GO TO 8960
      IAR(1) = 1
      IAR(INT2) = ISCR
      IAR(INT3) = NSCRBL
      CALL DB2316(IAR,J,MNAR,MNAR(NBRADR),IRC)
      CALL DB2209(MOREDF,NINPT)
      CALL DB2227
      CALL DB2315(82,MNAR(NBRADR))
      GO TO 9560
 1720 IFLGON = NDSPL
      IF(IARG1 .LT. 0) IFLGON = 0
      IARG1 = IABS(IARG1)
      IF(IARG1 .GT. 30) GO TO 9560
      IFLAG(IARG1) = IFLGON
      IF(IARG1 .NE. 8) GO TO 9560
      NVERFY = 0
      IVIER = 4
      IF(IFLGON .NE. 0) NVERFY = LOR(NVERFY,IVIER)
      GO TO 9560
 1760 IF (IARG1 .GT. 0) CALL DB2209(IARG1,NINPT)
      GO TO 9560
 1800 CALL DB2321(IAR,MNAR(NBRADR),NDPROP,MNAR,IRETCD)
      GO TO (9560,9530,1810), IRETCD
1810  IF(LAST .EQ. 0) GO TO 9560
      IF(ICATA(LAST) .EQ. 0) GO TO 9560
      CALL DB2232(MNAR,ICATA(LAST),IRK)
      IF(IRK .NE. 0) GO TO 9530
      ICATA(LAST) = 0
      LAST = 0
      IAR(1) = 1
      IAR(INT2) = ISCR
      IAR(INT3) = NSCRBL
      CALL DB2316(IAR,J,MNAR,MNAR(NBRADR),IRC)
      CALL DB2315(90,MNAR(NBRADR))
      GO TO 9560
1822  CALL DB2318(IAR(INT3),MNAR,MNAR(NBRADR),IRC)
      GO TO (9560,9490,9545,9530), IRC
1825  JUNK = 0
      IF(LAST .GT. 0) JUNK = ICATA(LAST)
      IRC = 1
C     CALL DB2332(IARG1,MNAR(NBRADR),MNAR,JUNK,IRC)
      IF(IRC - 1) 9530,9560,9530
 1840 IF(IOP2 - 2) 1880,2360,9160
 1880 LB = IAR(INT4)
      DO 1885 J = 1,4
      IF(IARG1 .EQ. IUSRN(J)) GO TO 1888
 1885 CONTINUE
      GO TO 1918
 1888 IMES = 34
      IF(LB .GT. 8) GO TO 9510
      IAR(INT2) = 6
      CALL DB2316(IAR(INT2),ISUBS,MNAR,MNAR(NBRADR),IRC)
      IRC = IRC + 3
      GO TO (9530,9545,2240,9490), IRC
 1918 IF(IARG1 .NE. ICELE) GO TO 1920
      IF(LB .NE. 4) GO TO 1920
      IF(IAR(INT5) .EQ. ICLAST) GO TO 2320
 1920 CALL DB2204(IARG1,IAR(INT5),LB,ID,L,NDSPL,IRK,MNAR(NBRADR),MNAR)
      IF(IRK .LE. 0) GO TO 9490
      LC = IAR(INT13)
      CALL DB2204(IARG1,IAR(INT14),
     1            LC,IDZ,LZ,NDSPL,IRK,MNAR(NBRADR),MNAR)
      IF(IRK .LE. 0) GO TO 9490
      IF(IRK .EQ. 12) GO TO 2200
      IF(IRK .NE. 15) GO TO 1960
      IF(LCOMP(ID,IDZ,L) .NE. 0) GO TO 1960
      CALL INTCHR(0,1,ID,4)
1960  III=1                                     !AWH 27 March 97 for Solaris
      IF(LCOMP(ID,IDZ,III) .NE. 0) GO TO 9120   !Don't pass constant 1 to function
      LCM = MIN0(L,LZ)
      IF(LCOMP(ID,IDZ,LCM) .GT. 0) GO TO 9120
      CALL DB2206(ID,L,IDZ,LZ,MNAR(NBRADR),MNAR,
     1ISUBS,IRETCD)
      GO TO (2240,9530,9545,9530,9490), IRETCD
 2200 IREL1 = ID(1)
      IREL2 = IDZ(1)
      IF(IREL2 .LT. IREL1) GO TO 9120
      CALL DB2228(MNAR,ISUBS,IREL1,IREL2,IR)
      IF(IR + 1) 9530,9545,2240
 2240 DO 2280 J = 1,MAXCAT
      IF(ICATA(J) .NE. 0) GO TO 2280
      IBACK = J
      ICATA(J) = ISUBS
      GO TO 2330
 2280 CONTINUE
      CALL DB2219(2201,2300)
      CALL DB2232(MNAR,ISUBS,IRK)
      IF(IRK) 9530,9200,9530
 2320 IMES = 12
      IF(LAST .LE. 0) GO TO 9480
      IBACK = LAST
      GO TO 2330
2330  IF(IFLAG(10) .EQ. 0) GO TO 9560
      CALL DB2300(MNAR,ICATA(IBACK),IBTCNT,IRC)
      IF(IRC+1) 9530,9545,2335
2335  CONTINUE
      CALL CICDC(IARG1,1,4)
      CALL CICDC(IAR(5),1,48)
      WRITE(NDSPL,2340) IARG1,IAR(INT5),IAR(INT6),IAR(INT7),
     1IAR(INT14),IAR(INT15),IAR(INT16),IBTCNT
2340  FORMAT(' FIND ',A4,' = ',3A4,' TO ',3A4,':',I7,' hits')
      GO TO 9560
 2360 LB = IAR(INT4)
      CALL DB2204(IARG1,IAR(INT5),LB,ID,L,NDSPL,IRK,MNAR(NBRADR),MNAR)
      IF(IRK .EQ. 12) GO TO 9000
      IF(IRK .LE. 0) GO TO 9510
      J = DB2210(0)
 2440 IRETCD = 0
      CALL DB2322(ID,L,MNAR(NBRADR),MNAR,IRETCD)
      IRETCD = IRETCD + 1
      GO TO (9560,9490,9545,9530), IRETCD
 2600 IF(IOP2 .GT. 10) GO TO 9160
      GO TO(2640,2800,2840,2840,2840,3080,3120,3320,3360,3370), IOP2
 2640 IF(IARG1 .LE. 0) GO TO 9530
      IF(IARG1 .GT. MAXCAT) GO TO 9530
      IF(ICATA(IARG1) .LE. 0) GO TO 9530
      DO 2680 J = 1,MAXCAT
      IF(ICATA(J) .EQ. 0) GO TO 2720
 2680 CONTINUE
      GO TO 9200
 2720 NEWPL = J
      CALL DB2229(MNAR,ICATA(IARG1),KOPADR,IRK)
      IF(IRK + 1) 9530,9545,2760
 2760 ICATA(NEWPL) = KOPADR
      IBACK = NEWPL
      GO TO 9560
 2800 IF(IARG1 .LE. 0) GO TO 9560
      IF(IARG1 .GT. MAXCAT) GO TO 9560
      IF(ICATA(IARG1) .LE. 0) GO TO 9560
      CALL DB2219(2201,3100)
      CALL DB2232(MNAR,ICATA(IARG1),IRK)
      IF(IRK .NE. 0) GO TO 9530
      ICATA(IARG1) = 0
      GO TO 9560
 2840 IF(IARG1 .LE. 0) GO TO 9530
      IF(IARG2 .LE. 0) GO TO 9530
      IF(IARG1 .GT. MAXCAT) GO TO 9530
      IF(IARG2 .GT. MAXCAT) GO TO 9530
      ICATA1 = ICATA(IARG1)
      IF(ICATA1 .LE. 0) GO TO 9530
      ICATA2 = ICATA(IARG2)
      IF(ICATA2 .LE. 0) GO TO 9530
      IF(IOP2 - 4) 2880,2920,2960
 2880 CALL DB2224(MNAR,ICATA1,ICATA2,IRK)
      GO TO 3000
 2920 CALL DB2220(MNAR,ICATA1,ICATA2,IRK)
      GO TO 3000
 2960 CALL DB2223(MNAR,ICATA1,ICATA2,IRK)
 3000 IF(IRK + 1) 9530,9545,3040
 3040 ICATA(IARG1) = ICATA1
      GO TO 9560
 3080 GO TO 2800
 3120 IF(LAST .EQ. 0) GO TO 3160
      IF(LAST .GT. MAXCAT) GO TO 9530
      IF(ICATA(LAST) .LE. 0) GO TO 9530
      CALL DB2219(2201,3600)
      CALL DB2232(MNAR,ICATA(LAST),IRK)
      IF(IRK .NE. 0) GO TO 9530
      ICATA(LAST) = 0
 3160 IF(IARG1 .LE. 0) GO TO 9530
      IF(IARG1 .GT. MAXCAT) GO TO 9530
      IF(ICATA(IARG1) .LE. 0) GO TO 9530
      LAST = IARG1
 3200 CALL DB2300(MNAR,ICATA(LAST),IBTCNT,IRC)
      IF(IRC + 1) 9530,9545,3240
 3240 WRITE(NDSPL,3280) IBTCNT
 3280 FORMAT(' Current subset ("LAST") contains',I7,' entries.')
      GO TO 9560
 3320 IF(IARG1 .LE. 0) GO TO 9530
      IF(IARG1 .GT. MAXCAT) GO TO 9530
      IF(ICATA(IARG1) .LE. 0) GO TO 9530
      CALL DB2300(MNAR,ICATA(IARG1),IBTCNT,IRK)
      IF(IRK + 1) 9530,9545,9560
 3360 CALL DB2233(MNAR,NDSPL)
      GO TO 9560
C
C ********************
C ---ADAPTATION (2-10)
C W*******************
C
 3370 CONTINUE
      CALL DB2335(NINPT,NDSPL,ITABL)
      GO TO 9560
C
 3400 IF(IOP2 .GT. 4) GO TO 3720
      IF(LAST .LE. 0) GO TO 9240
      IADR = ICATA(LAST)
      IF(IADR .LE. 0) GO TO 9240
      MODUS = 0
      GO TO (3420,3440,3500,3640), IOP2
3420  IF(IARG1) 3600,3620,3620
3440  IFLAG(33) = NPRTR
      IFLAG(32) = 1
      IFLAG(41) = 1
      IF(IARG1) 3600,3620,3620
3500  MODUS = 1
      IF(IARG1 .EQ. -1) GO TO 3600
      IFLAG(32) = 2
      IFLAG(33) = IFRMFL
      IF(IARG1 .GT. 0) IFLAG(33) = IARG1
      ASSIGN 3600 TO NRET
      GO TO 7000
 3600 IRETCD = 0
      CALL DB2211(MNAR,IADR,MODUS,IAR(INT5),IARG2,
     1IRETCD,MNAR(NBRADR),ARMN)
      IF(IRETCD .EQ. 0) GO TO 9560
      IMES = 10
      GO TO(9545,9545,9530,9530,9550),IRETCD
3620  IFLAG(32) = 2
      IFLAG(33) = IFRMFL
      IF(IARG1 .GT. 0) IFLAG(33) = IARG1
      ASSIGN 3630 TO NRET
      GO TO 7000
3630  CALL DB2212(MNAR,IADR,IAR(INT5),IARG2,IRETCD,MNAR(NBRADR))
      IF(IRETCD .EQ. 0) GO TO 9560
      GO TO(9545,9530,9490), IRETCD
 3640 IRETCD = 0
      CALL DB2216(MNAR,IADR,IARG1,IAR(INT5),IARG2,
     1IRETCD,MNAR(NBRADR))
 3660 IF(IRETCD-1) 3680,9545,9530
 3680 ICATA(LAST) = IADR
      GO TO 3200
 3720 IF(IOP2 .GT.7) GO TO 9160
      JUNK = IOP2 - 4
      GO TO (3740,3770,3775), JUNK
 3740 IF(LAST .LE. 0) GO TO 9240
      IADR = ICATA(LAST)
      IRETCD = -1
      IMES = 62
C ********************
C ---CALL PLOT PACKAGE
C W*******************
      CALL DB2310(MNAR,IADR,MNAR(NBRADR),IRETCD)
C     CALL DB2310(MNAR,IADR,MNAR(NBRADR),IRETCD)
      IRETCD = IRETCD + 2
      GO TO (9480,9560,9545,9530,9530), IRETCD
 3760 IF(IOP2 .GT. 5) GO TO 9160
      GO TO (3800,4000,4100,4200,4200), IOP2
 3770 IF(LAST .LE. 0) GO TO 9240
      IADR = ICATA(LAST)
      CALL DB2330(MNAR,IAR(INT4),IARG1,IADR,MNAR(NBRADR),IRETCD)
      ICATA(LAST) = IADR
      GO TO (9560,9560,9240,9200,9530,9530),IRETCD
3775  IELOFL = 0
      IARG1 = MIN0(IARG1,MXLORD)
      IF(IARG1 .LE. 0) GO TO 9560
      IELOFL = IARG1
      IMES = 110
      DO 3780 J = 1,IELOFL
      CALL DB2012(IAR(J+3),LEN,ID)
      IF(ID(1) .LE. 0) GO TO 9550
      IELORD(J) = ID(1)
3780  CONTINUE
      GO TO 9560
 3800 IF(IAR(INT5)-1) 3960,3880,3920
 3880 IFLAG(28) = 0
      GO TO 9560
 3920 IFLAG(28) = 1
      GO TO 9560
 3960 CALL DB2217(MNAR,IAR(INT3),MNAR(NBRADR),IRK)
      IF(IRK + 1) 9530,9545,9560
 4000 IF(LAST .LE. 0) GO TO 9240
      IAR(INT5) = ICATA(LAST)
      IF(IAR(INT5) .LE. 0) GO TO 9240
      CALL DB2316(IAR(INT2),J,MNAR,MNAR(NBRADR),IRC)
      IF (IRC) 9530,9560,9560
 4100 CALL DB2316(IAR(INT2),J,MNAR,MNAR(NBRADR),IRC)
      IF(IRC) 9530,9560,9490
 4200 CALL DB2316(IAR(INT2),J,MNAR,MNAR(NBRADR),IRC)
      IF(IRC+1) 9530,9545,9560
 4400 IF(LAST .LE. 0) GO TO 9240
      IADR = ICATA(LAST)
      IF(IADR .LE. 0) GO TO 9240
      IF(IARG1 .LT. 0) GO TO 4500
      IFLAG(32) = 2
      IFLAG(33) = IFRMFL
      IF(IARG1 .GT. 0) IFLAG(33) = IARG1
      IF(IOP2 .GT. 2) IAR(INT2) = IOP2 - 2
      ASSIGN 4600 TO NRET
      GO TO 7000
4500  IF(IOP2 .LE. 2) GO TO 4600
      IFLAG(32) = 1
      IFLAG(41) = 1
      IAR(INT2) = IOP2 - 2
      IFLAG(33) = NPRTR
4600  IRETCD = 3
      IMES = 64
C ************************************
C ---CALL DISTANCE- AND ANGLES-PACKAGE
C W***********************************
      CALL DB2314(MNAR,IADR,IAR,IRETCD,MNAR(NBRADR))
C     CALL DB2314(MNAR,IADR,IAR,IRETCD,MNAR(NBRADR))
      IRETCD = IRETCD + 3
      GO TO (3680,9490,9560,9545,9530,9480), IRETCD
7000  IMES = 44
      IF(ISPECU .EQ. 0) GO TO 9480
      IPORT = IFLAG(33)
      CALL DB2338(IPORT,IRETCD)
      IF(IRETCD .NE. 0) GO TO 9490
      GO TO NRET, (3600,3630,4600)
 8960 WRITE(NDSPL,8980)
 8980 FORMAT(' Partition "MESSAGES" in tables file not found')
      GO TO 9530
 9000 IMES = 2
      GO TO 9500
 9040 WRITE(NDSPL,9060)
 9060 FORMAT(' DB2201 - Array MNAR is too small.')
      GO TO 9530
 9080 WRITE(NDSPL,9100) NBRADR,IDBCB
 9100 FORMAT(' DB2201 - System error. NBRADR=',I6,'  IDBCB=',I6)
      GO TO 9530
 9120 IMES = 4
      GO TO 9480
 9160 WRITE(NDSPL,9180) IOP1,IOP2
 9180 FORMAT(' DB2201 - Invalid internal opcode',2I4)
      GO TO 9530
 9200 IMES = 6
      GO TO 9540
 9240 IMES = 8
      GO TO 9550
 9480 CALL DB2315(IMES,MNAR(NBRADR))
 9490 IRC = 6
      GO TO 9580
 9500 CALL DB2315(IMES,MNAR(NBRADR))
 9510 IRC = 1
      GO TO 9580
 9530 IRC = -2
      GO TO 9580
 9540 CALL DB2315(IMES,MNAR(NBRADR))
 9545 IRC = -1
      GO TO 9580
 9550 CALL DB2315(IMES,MNAR(NBRADR))
 9560 IRC = 0
 9580 CONTINUE
      IF(IFLAG(9) .EQ. 0) GO TO 9700
      IF(NRDCNT .NE. NRDCM) WRITE(NDSPL,9600) NRDCNT
 9600 FORMAT(' DB2201 -',I6,' phys. input operations since session ',
     1'start')
      NRDCM = NRDCNT
 9700 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2204
      SUBROUTINE DB2204(ICLASS,IDB,LB,ID,L,NPRINT,IRC,NBRAS,MNAR)
      PARAMETER (IZKL=30)
      COMMON /DC2201/ IFLAG(50)
      DIMENSION IDB(*),ID(*),LIST(10),MINKL(2),NBRAS(*),MNAR(*)
      DIMENSION ITEXT(102)
      DIMENSION IDSLEN(IZKL)
       DIMENSION NELSYX(1),IPLUSX(1),MINUSX(1)
      DIMENSION ILINE(20)
      DIMENSION NAMSYM(IZKL)
      DATA NSMAX/IZKL/
CHP8  DATA NAMSYM/'COL ','ELE ','ELE ','ELE ','AUT ','MINR','TEST',
C    1     'YEAR','CODN','REM ','ELC ','REL ','RVAL','ELE ','D   ',
C    2     'CVOL','SGR ','SGR ','SYST','CLAS','LAUE','SYPR','ANX ',
C    3     'PRS ','FR##','RFCD','CHCL','DATE','Z   ','STAT'/
Cmw      DATANAMSYM/Z'C3D6D340',Z'C5D3C540',Z'C5D3C540',Z'C5D3C540',Z'C1E4E
Cmw     $340',Z'D4C9D5D9',Z'E3C5E2E3',Z'E8C5C1D9',Z'C3D6C4D5',Z'D9C5D440',Z
Cmw     $'C5D3C340',Z'D9C5D340',Z'D9E5C1D3',Z'C5D3C540',Z'C4404040',Z'C3E5D
Cmw     $6D3',Z'E2C7D940',Z'E2C7D940',Z'E2E8E2E3',Z'C3D3C1E2',Z'D3C1E4C5',Z
Cmw     $'E2E8D7D9',Z'C1D5E740',Z'D7D9E240',Z'C6D97B7B',Z'D9C6C3C4',Z'C3C8C
Cmw     $3D3',Z'C4C1E3C5',Z'E9404040',Z'E2E3C1E3'/
      DATANAMSYM/Z'40D3D6C3',Z'40C5D3C5',Z'40C5D3C5',Z'40C5D3C5',Z'40E3E
     $4C1',Z'D9D5C9D4',Z'E3E2C5E3',Z'D9C1C5E8',Z'D5C4D6C3',Z'40D4C5D9',Z
     $'40C3D3C5',Z'40D3C5D9',Z'D3C1E5D9',Z'40C5D3C5',Z'404040C4',Z'D3D6E
     $5D3',Z'40D9C7E2',Z'40D9C7E2',Z'E3E2E8E2',Z'E2C1D3C3',Z'C5E4C1D3',Z
     $'D9D7E8E2',Z'40E7D5C1',Z'40E2D9D7',Z'7B7BD9C6',Z'C4C3C6D9',Z'D3C3C
     $8D3',Z'C5E3C1C4',Z'404040E9',Z'E3C1E3E2'/
CHP8  DATA IPLUS/'+'/ , MINUS/'-'/, IBLANK/'    '/, ICL/'L'/,
C    1IEND/'END '/, MINKL/'-','-'/, ICR/'R'/, ICU/'U'/
Cmw      DATAIPLUS/Z'4E404040'/,MINUS/Z'60404040'/,IBLANK/Z'40404040'/,ICL/
Cmw     $Z'D3404040'/,IEND/Z'C5D5C440'/,MINKL/Z'60404040',Z'60404040'/,ICR/
Cmw     $Z'D9404040'/,ICU/Z'E4404040'/
      DATAIPLUS/Z'4040404E'/,MINUS/Z'40404060'/,IBLANK/Z'40404040'/,ICL/
     $Z'404040D3'/,IEND/Z'40C4D5C5'/,MINKL/Z'40404060',Z'40404060'/,ICR/
     $Z'404040D9'/,ICU/Z'404040E4'/
CHP8  DATA IPLUSX(1)/'+'/, MINUSX(1)/'-'/
Cmw      DATAIPLUSX(1)/Z'4E404040'/,MINUSX(1)/Z'60404040'/
      DATAIPLUSX(1)/Z'4040404E'/,MINUSX(1)/Z'40404060'/
      DATA MAXTXT/102/
CHP8  DATA
C    1ITEXT( 1),ITEXT( 2),ITEXT( 3),ITEXT( 4),ITEXT( 5),
C    2ITEXT( 6),ITEXT( 7),ITEXT( 8),ITEXT( 9),ITEXT(10),
C    3ITEXT(11),ITEXT(12),ITEXT(13),ITEXT(14),ITEXT(15),
C    4ITEXT(16),ITEXT(17),ITEXT(18),ITEXT(19),ITEXT(20),
C    5ITEXT(21),ITEXT(22),ITEXT(23),ITEXT(24),ITEXT(25),
C    6ITEXT(26),ITEXT(27),ITEXT(28),ITEXT(29),ITEXT(30)/
C    7'Ill.',' cha','r. i','n ke','ywor','d   ','    ','Elem','ent ',
C    8'grou','p no','t pe','rmit','ted ','    ','Inva','lid ','ox. ',
C    9'stat','e   ','    ','Inva','lid ','year','    ','Code','n no',
C    A't 5 ','char','acte'/
Cmw      DATAITEXT(1),ITEXT(2),ITEXT(3),ITEXT(4),ITEXT(5),ITEXT(6),ITEXT(7)
Cmw     $,ITEXT(8),ITEXT(9),ITEXT(10),ITEXT(11),ITEXT(12),ITEXT(13),ITEXT(1
Cmw     $4),ITEXT(15),ITEXT(16),ITEXT(17),ITEXT(18),ITEXT(19),ITEXT(20),ITE
Cmw     $XT(21),ITEXT(22),ITEXT(23),ITEXT(24),ITEXT(25),ITEXT(26),ITEXT(27)
Cmw     $,ITEXT(28),ITEXT(29),ITEXT(30)/Z'C993934B',Z'40838881',Z'994B4089'
Cmw     $,Z'95409285',Z'A8A69699',Z'84404040',Z'40404040',Z'C5938594',Z'859
Cmw     $5A340',Z'879996A4',Z'97409596',Z'A3409785',Z'999489A3',Z'A3858440'
Cmw     $,Z'40404040',Z'C995A581',Z'93898440',Z'96A74B40',Z'A2A381A3',Z'854
Cmw     $04040',Z'40404040',Z'C995A581',Z'93898440',Z'A8858199',Z'40404040'
Cmw     $,Z'C3968485',Z'95409596',Z'A340F540',Z'83888199',Z'8183A385'/
      DATAITEXT(1),ITEXT(2),ITEXT(3),ITEXT(4),ITEXT(5),ITEXT(6),ITEXT(7)
     $,ITEXT(8),ITEXT(9),ITEXT(10),ITEXT(11),ITEXT(12),ITEXT(13),ITEXT(1
     $4),ITEXT(15),ITEXT(16),ITEXT(17),ITEXT(18),ITEXT(19),ITEXT(20),ITE
     $XT(21),ITEXT(22),ITEXT(23),ITEXT(24),ITEXT(25),ITEXT(26),ITEXT(27)
     $,ITEXT(28),ITEXT(29),ITEXT(30)/Z'4B9393C9',Z'81888340',Z'89404B99'
     $,Z'85924095',Z'9996A6A8',Z'40404084',Z'40404040',Z'948593C5',Z'40A
     $39585',Z'A4969987',Z'96954097',Z'859740A3',Z'A3899499',Z'408485A3'
     $,Z'40404040',Z'81A595C9',Z'40848993',Z'404BA796',Z'A381A3A2',Z'404
     $04085',Z'40404040',Z'81A595C9',Z'40848993',Z'998185A8',Z'40404040'
     $,Z'858496C3',Z'96954095',Z'40F540A3',Z'99818883',Z'85A38381'/
CHP8  DATA
C    1ITEXT(31),ITEXT(32),ITEXT(33),ITEXT(34),ITEXT(35),
C    2ITEXT(36),ITEXT(37),ITEXT(38),ITEXT(39),ITEXT(40),
C    3ITEXT(41),ITEXT(42),ITEXT(43),ITEXT(44),ITEXT(45),
C    4ITEXT(46),ITEXT(47),ITEXT(48),ITEXT(49),ITEXT(50),
C    5ITEXT(51),ITEXT(52),ITEXT(53),ITEXT(54),ITEXT(55),
C    6ITEXT(56),ITEXT(57),ITEXT(58),ITEXT(59),ITEXT(60)/
C    7'rs  ','    ','Inva','lid ','elem','ent ','coun','t   ','    ',
C    8'Inva','lid ','rel ','spec','ific','atio','n   ','    ','keyw',
C    9'ord ','too ','long','    ','Inva','lid ','rval','    ','Inva',
C    A'lid ','stoi','ch. '/
Cmw      DATAITEXT(31),ITEXT(32),ITEXT(33),ITEXT(34),ITEXT(35),ITEXT(36),IT
Cmw     $EXT(37),ITEXT(38),ITEXT(39),ITEXT(40),ITEXT(41),ITEXT(42),ITEXT(43
Cmw     $),ITEXT(44),ITEXT(45),ITEXT(46),ITEXT(47),ITEXT(48),ITEXT(49),ITEX
Cmw     $T(50),ITEXT(51),ITEXT(52),ITEXT(53),ITEXT(54),ITEXT(55),ITEXT(56),
Cmw     $ITEXT(57),ITEXT(58),ITEXT(59),ITEXT(60)/Z'99A24040',Z'40404040',Z'
Cmw     $C995A581',Z'93898440',Z'85938594',Z'8595A340',Z'8396A495',Z'A34040
Cmw     $40',Z'40404040',Z'C995A581',Z'93898440',Z'99859340',Z'A2978583',Z'
Cmw     $89868983',Z'81A38996',Z'95404040',Z'40404040',Z'9285A8A6',Z'969984
Cmw     $40',Z'A3969640',Z'93969587',Z'40404040',Z'C995A581',Z'93898440',Z'
Cmw     $99A58193',Z'40404040',Z'C995A581',Z'93898440',Z'A2A39689',Z'83884B
Cmw     $40'/
      DATAITEXT(31),ITEXT(32),ITEXT(33),ITEXT(34),ITEXT(35),ITEXT(36),IT
     $EXT(37),ITEXT(38),ITEXT(39),ITEXT(40),ITEXT(41),ITEXT(42),ITEXT(43
     $),ITEXT(44),ITEXT(45),ITEXT(46),ITEXT(47),ITEXT(48),ITEXT(49),ITEX
     $T(50),ITEXT(51),ITEXT(52),ITEXT(53),ITEXT(54),ITEXT(55),ITEXT(56),
     $ITEXT(57),ITEXT(58),ITEXT(59),ITEXT(60)/Z'4040A299',Z'40404040',Z'
     $81A595C9',Z'40848993',Z'94859385',Z'40A39585',Z'95A49683',Z'404040
     $A3',Z'40404040',Z'81A595C9',Z'40848993',Z'40938599',Z'838597A2',Z'
     $83898689',Z'9689A381',Z'40404095',Z'40404040',Z'A6A88592',Z'408499
     $96',Z'409696A3',Z'87959693',Z'40404040',Z'81A595C9',Z'40848993',Z'
     $9381A599',Z'40404040',Z'81A595C9',Z'40848993',Z'8996A3A2',Z'404B88
     $83'/
CHP8  DATA
C    1ITEXT(61),ITEXT(62),ITEXT(63),ITEXT(64),ITEXT(65),
C    2ITEXT(66),ITEXT(67),ITEXT(68),ITEXT(69),ITEXT(70),
C    3ITEXT(71),ITEXT(72),ITEXT(73),ITEXT(74),ITEXT(75),
C    4ITEXT(76),ITEXT(77),ITEXT(78),ITEXT(79),ITEXT(80),
C    5ITEXT(81),ITEXT(82),ITEXT(83),ITEXT(84),ITEXT(85),
C    6ITEXT(86),ITEXT(87),ITEXT(88),ITEXT(89),ITEXT(90)/
C    7'coef','f.  ','    ','Dist','ance',' inv','alid',' or ','miss',
C    8'ing ','    ','Inva','lid ','cell',' vol','ume ','    ','Coll',
C    9'. co','de o','ut o','f ra','nge ','    ','Inva','lid ','test',
C    A' cod','e   ','    '/
Cmw      DATAITEXT(61),ITEXT(62),ITEXT(63),ITEXT(64),ITEXT(65),ITEXT(66),IT
Cmw     $EXT(67),ITEXT(68),ITEXT(69),ITEXT(70),ITEXT(71),ITEXT(72),ITEXT(73
Cmw     $),ITEXT(74),ITEXT(75),ITEXT(76),ITEXT(77),ITEXT(78),ITEXT(79),ITEX
Cmw     $T(80),ITEXT(81),ITEXT(82),ITEXT(83),ITEXT(84),ITEXT(85),ITEXT(86),
Cmw     $ITEXT(87),ITEXT(88),ITEXT(89),ITEXT(90)/Z'83968586',Z'864B4040',Z'
Cmw     $40404040',Z'C489A2A3',Z'81958385',Z'408995A5',Z'81938984',Z'409699
Cmw     $40',Z'9489A2A2',Z'89958740',Z'40404040',Z'C995A581',Z'93898440',Z'
Cmw     $83859393',Z'40A59693',Z'A4948540',Z'40404040',Z'C3969393',Z'4B4083
Cmw     $96',Z'84854096',Z'A4A34096',Z'86409981',Z'95878540',Z'40404040',Z'
Cmw     $C995A581',Z'93898440',Z'A385A2A3',Z'40839684',Z'85404040',Z'404040
Cmw     $40'/
      DATAITEXT(61),ITEXT(62),ITEXT(63),ITEXT(64),ITEXT(65),ITEXT(66),IT
     $EXT(67),ITEXT(68),ITEXT(69),ITEXT(70),ITEXT(71),ITEXT(72),ITEXT(73
     $),ITEXT(74),ITEXT(75),ITEXT(76),ITEXT(77),ITEXT(78),ITEXT(79),ITEX
     $T(80),ITEXT(81),ITEXT(82),ITEXT(83),ITEXT(84),ITEXT(85),ITEXT(86),
     $ITEXT(87),ITEXT(88),ITEXT(89),ITEXT(90)/Z'86859683',Z'40404B86',Z'
     $40404040',Z'A3A289C4',Z'85839581',Z'A5958940',Z'84899381',Z'409996
     $40',Z'A2A28994',Z'40879589',Z'40404040',Z'81A595C9',Z'40848993',Z'
     $93938583',Z'9396A540',Z'408594A4',Z'40404040',Z'939396C3',Z'968340
     $4B',Z'96408584',Z'9640A3A4',Z'81994086',Z'40858795',Z'40404040',Z'
     $81A595C9',Z'40848993',Z'A3A285A3',Z'84968340',Z'40404085',Z'404040
     $40'/
CHP8  DATA
C    1ITEXT(91),ITEXT(92),ITEXT(93),ITEXT(94),ITEXT(95),
C    2ITEXT(96),ITEXT(97),ITEXT(98),ITEXT(99),ITEXT(100),
C    3ITEXT(101),ITEXT(102)/
C    7'Inva','lid ','rema','rk c','ode ','    ','Inva','lid ','spac',
C    8'e gr','oup ','    '/
Cmw      DATAITEXT(91),ITEXT(92),ITEXT(93),ITEXT(94),ITEXT(95),ITEXT(96),IT
Cmw     $EXT(97),ITEXT(98),ITEXT(99),ITEXT(100),ITEXT(101),ITEXT(102)/Z'C99
Cmw     $5A581',Z'93898440',Z'99859481',Z'99924083',Z'96848540',Z'40404040'
Cmw     $,Z'C995A581',Z'93898440',Z'A2978183',Z'85408799',Z'96A49740',Z'404
Cmw     $04040'/
      DATAITEXT(91),ITEXT(92),ITEXT(93),ITEXT(94),ITEXT(95),ITEXT(96),IT
     $EXT(97),ITEXT(98),ITEXT(99),ITEXT(100),ITEXT(101),ITEXT(102)/Z'81A
     $595C9',Z'40848993',Z'81948599',Z'83409299',Z'40858496',Z'40404040'
     $,Z'81A595C9',Z'40848993',Z'838197A2',Z'99874085',Z'4097A496',Z'404
     $04040'/
      DATA IDSLEN/4,2,3,2,0,0,3,2,6,2,2,4,2,4,4,2,9,2,4,6,6,5,0,0,0,
     1            7,2,4,2,2/
     
      L = 1
      IF(ICLASS .NE. IEND) GO TO 180
      J = 255
      GO TO 300
180   DO 200 J = 1,NSMAX
      IF(ICLASS .EQ. NAMSYM(J)) GO TO 300
200   CONTINUE
      IF(ICLASS .EQ. ICL) GO TO 3400
      GO TO 9040
300   NS = J
      L = IDSLEN(NS)
      CALL INTCHR(NS,1,ID,1)
      IF(LB .GT. 0) GO TO 360
      L = 1
      GO TO 9800
360   GO TO (400,500,500,500,900,900,2100,1100,1200,2200,1400,1500,
     11600,500,1700,2000,2300,2300,2500,2600,2600,2700,2800,900,
     2900,2900,3000,3200,4000,4200),NS
400   CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      JT = 1
      IF(ICODE .LE. LB) GO TO 8000
      JT = 78
      IF(IZAHL .LE. 0) GO TO 8000
      IF(IZAHL .GE. 1000000) GO TO 8000
      CALL INTCHR(IZAHL,3,ID,2)
      GO TO 9800
500   NELSYM = IBLANK
      DO 540 J = 1,LB
      IF(J .EQ. 1) GO TO 520
      JP = J
      NS = 3
      FAK = 1.0
      IF(LCOMPS(IDB,J,1,IPLUSX(1),1) .EQ. 0) GO TO 560
      FAK = -1.0
      IF(LCOMPS(IDB,J,1,MINUSX(1),1) .EQ. 0) GO TO 560
      CALL DB2208(IDB,J,LB,ZAHL,ICODE)
      NS = 14
      IF(ICODE .GT. J) GO TO 560
520   NELSYX(1) = NELSYM
      CALL COPYCH(IDB,J,1,NELSYX(1),J)
      NELSYM = NELSYX(1)
      IF (J .GT. 3) GO TO 9160
540   CONTINUE
      NS = 2
560   NELSYX(1) = NELSYM
      CALL DB2012(NELSYX(1),LEN,LIST)
      IF(LIST(1) .LE. 0) GO TO 9160
      IF(LIST(1) .LT. 128) GO TO 580
      JT = 8
      IF(NS .NE. 2) GO TO 8000
      NS = 4
      GO TO 700
580   IF(NS .NE. 3) GO TO 600
      JP = JP + 1
      JT = 16
      L = 3
      IF(JP .GT. LB) GO TO 8000
      CALL DB2208(IDB,JP,LB,ZAHL,IRC)
      IF(IRC .LE. LB) GO TO 8000
      ZAHL = ZAHL * FAK
      ZAHL = AMAX1(ZAHL,-4.0)
      ZAHL = AMIN1(ZAHL,8.0)
      IZAHL = (ZAHL + 4.025) * 20.0
      CALL INTCHR(IZAHL,1,ID,3)
      GO TO 700
600   IF(NS .NE. 14) GO TO 700
      JT = 57
      L = 4
      IF(ICODE .LE. LB) GO TO 8000
      IZAHL = ZAHL * 10.0 + 0.5
      IZAHL = MIN0(2550,IZAHL)
      IZHL10 = IZAHL/10
      CALL INTCHR(IZHL10,1,ID,3)
      IZHL10 = MOD(IZAHL,10)
      CALL INTCHR(IZHL10,1,ID,4)
700   CALL INTCHR(NS,1,ID,1)
      CALL INTCHR(LIST(1),1,ID,2)
      GO TO 9800
900   JT = 48
      IF(LB .GT. 31) GO TO 8000
      CALL COPYCH(IDB,1,LB,ID,2)
      L = LB + 1
      GO TO 9800
1100  CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      JT = 22
      IF(ICODE .LE. LB) GO TO 8000
      IF(IZAHL .LT.  0) GO TO 8000	!AWH 25Apr02 Millennium bug 12->0
      IF(IZAHL .GT. 99) GO TO 8000
      CALL INTCHR(IZAHL,1,ID,2)
      GO TO 9800
1200  JT = 26
      IF(LB .NE. 5) GO TO 8000
      CALL COPYCH(IDB,1,5,ID,2)
      GO TO 9800
1400  CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      JT = 33
      IF(ICODE .LE. LB) GO TO 8000
      IF(IZAHL .GT. 32) GO TO 8000
      CALL INTCHR(IZAHL,1,ID,2)
      GO TO 9800
1500  CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      JT = 40
      IF(ICODE .LE. LB) GO TO 8000
      IF(IZAHL .LT. 1) GO TO 8000
      IF(IZAHL .GT.200000) GO TO 8000
      ID(1) = IZAHL
      GO TO 9800
1600  CALL DB2208(IDB,1,LB,ZAHL,ICODE)
      JT = 53
      IF(ICODE .LE. LB) GO TO 8000
      IZAHL = ZAHL*1000.0 + 0.5
      IF(IZAHL .LT. 0) GO TO 8000
      IF(IZAHL .GT. 255) GO TO 8000
      CALL INTCHR(IZAHL,1,ID,2)
      GO TO 9800
1700  IBP = 0
      DO 1900 J = 1,2
      NELSYM = IBLANK
      NELP = 0
1740  IBP = IBP + 1
      IF(IBP .GT. LB) GO TO 9160
      IF(LCOMPS(IDB,IBP,1,MINKL(J),1) .EQ. 0) GO TO 1800
      NELP = NELP + 1
      IF(NELP .GT. 2) GO TO 9160
      NELSYX(1) = NELSYM
      CALL COPYCH(IDB,IBP,1,NELSYX(1),NELP)
      NELSYM = NELSYX(1)
      GO TO 1740
1800  NELSYX(1) = NELSYM
      CALL DB2012(NELSYX(1),LEN,LIST)
      IF(LIST(1) .LE. 0) GO TO 9160
      JT = 8
      IF(LIST(1) .GT. 128) GO TO 8000
      CALL INTCHR(LIST(1),1,ID,1+J)
1900  CONTINUE
      JT = 64
      IF(IBP .GE. LB) GO TO 8000
      CALL DB2208(IDB,IBP+1,LB,ZAHL,IRC)
      IF(IRC .LE. LB) GO TO 8000
      IZAHL = ZAHL*50.0 + 0.5
      IF(IZAHL .GT. 255) GO TO 8000
      CALL INTCHR(IZAHL,1,ID,4)
      GO TO 9800
2000  CALL DB2208(IDB,1,LB,ZAHL,ICODE)
      JT = 72
      IF (ICODE .LE. LB) GO TO 8000
      IZAHL = SQRT(ZAHL) + 0.5
      IZAHL = MIN0(IZAHL,255)
      CALL INTCHR(IZAHL,1,ID,2)
      GO TO 9800
2100  CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      JT = 85
      IF(ICODE .LE. LB) GO TO 8000
      IF(IZAHL .LT. 11) GO TO 8000
      IF(IZAHL .GT. 78) GO TO 8000
      IZHL10 = IZAHL/10
      CALL INTCHR(IZHL10,1,ID,2)
      IZHL10 = MOD(IZAHL,10)
      CALL INTCHR(IZHL10,1,ID,3)
      GO TO 9800
2200  JT = 91
      IF(LB .GT. 4) GO TO 8000
      IF(LB .LT. 3) GO TO 8000
      NELSYM = IDB(1)
      CALL DB2008(NELSYM,IZAHL)
      IF(IZAHL .LE. 0) GO TO 8000
      CALL INTCHR(IZAHL,1,ID,2)
      GO TO 9800
2300  CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      JT = 97
      IF(ICODE .EQ. 1) GO TO 2340
      IF(ICODE - LB) 8000,8000,2360
2340  JT = 48
      IF(LB .GT. 8) GO TO 8000
      CALL COPYCH(IDB,1,8,ID,2)
      GO TO 9800
2360  NS = 18
      L = IDSLEN(NS)
      IMES = 76
      IF(IZAHL .GT. 230) GO TO 9600
      CALL INTCHR(IZAHL,1,ID,2)
      CALL INTCHR(NS,1,ID,1)
      GO TO 9800
2500  JT = 48
      IF (LB .GT. 3) GO TO 8000
      CALL COPYCH(IDB,1,3,ID,2)
      GO TO 9800
2600  JT = 48
      IF(LB .GT. 5) GO TO 8000
      CALL COPYCH(IDB,1,5,ID,2)
      GO TO 9800
2700  JT = 48
      IF(LB .GT. 4) GO TO 8000
      CALL COPYCH(IDB,1,4,ID,2)
      GO TO 9800
2800  IBUCH = 0
      IMES = 78
      DO 2840 J = 1,LB
      CALL CONVCI(IDB,J,IZIF)
      IF(IZIF .GE. 0) GO TO 2840
      IF(IZIF .NE. -4) GO TO 9600
      IBUCH = IBUCH + 1
2840  CONTINUE
      IF(IBUCH .LE. 0) GO TO 9600
      CALL INTCHR(IBUCH,1,ID,2)
      CALL COPYCH(IDB,1,LB,ID,3)
      L = LB + 2
      GO TO 9800
2900  CALL COPYCH(IDB,1,6,ID,2)
      GO TO 9800
3000  CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      CALL INTCHR(IZAHL,1,ID,2)
      GO TO 9800
3200  IMES = 80
      IF(LB .NE. 7) GO TO 9600
      JUNK = 0
      IF(LCOMP(IDB,ICR,1) .EQ. 0) GO TO 3240
      IF(LCOMP(IDB,ICU,1) .NE. 0) GO TO 9600
      JUNK = 1000000
3240  CALL DB2205(IDB,2,LB,IZAHL,ICODE)
      IF(ICODE .LE. LB) GO TO 9600
      CALL INTCHR(IZAHL+JUNK,3,ID,2)
      GO TO 9800
3400  IMES = 96
      CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      IF(ICODE .LE. LB) GO TO 9600
      IF(IZAHL .LE. 0) GO TO 9600
      IDBCB = IFLAG(40)
      IACTBS = MNAR(IDBCB+2)
      IMES = 98
      IF(IACTBS .LE. 0) GO TO 9600
      IDSPCH = IFLAG(39)
      IADUHD = IDSPCH + MNAR(IDSPCH)
      LENSPB = MNAR(IDSPCH+1)
      LDSB = MNAR(IDSPCH+4)
      DO 3600 J = 1,IACTBS
      IZAGD = MNAR(IADUHD)
      IF (IZAGD .LE. 0) GO TO 3500
      ISPBL = IADUHD + MNAR(IDSPCH+3)
      DO 3450 IZ = 1,IZAGD
      IF(MNAR(ISPBL+10) .EQ. IZAHL) GO TO 3650
      ISPBL = ISPBL + LDSB
3450  CONTINUE
3500  IADUHD = IADUHD + LENSPB
3600  CONTINUE
      GO TO 9600
3650  CALL COPYCH(MNAR(ISPBL+2),1,MNAR(ISPBL),ID,1)
      L = MNAR(ISPBL)
      GO TO 9800
4000  CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      JT = 1
      IF(ICODE .LE. LB) GO TO 8000
      CALL INTCHR(IZAHL,1,ID,2)
      GO TO 9800
4200  CALL DB2205(IDB,1,LB,IZAHL,ICODE)
      JT = 1
      IF(ICODE .LE. LB) GO TO 8000
      CALL INTCHR(IZAHL,1,ID,2)
      GO TO 9800
8000  DO 8020 J = JT,MAXTXT
      IF(ITEXT(J) .EQ. IBLANK) GO TO 8040
8020  JEND = J
8040  JE = JEND-JT+1
      CALL CICDCS(ITEXT(JT),1,JE*4,ILINE)
      WRITE(NPRINT,8060) (ILINE(J),J=1,JE)
8060  FORMAT(' DB2204 - ',15A4)
      GO TO 9700
9040  CONTINUE
      WRITE(NPRINT,9060) ICLASS
9060  FORMAT(' DB2204 - ILL. KEYWORD CLASS ',A4)
      GO TO 9700
9160  CONTINUE
      CALL CICDC(NELSYM,1,4)
      WRITE(NPRINT,9180) NELSYM
9180  FORMAT(' DB2204 - Invalid element or element group symbol ',A4)
      GO TO 9700
9600  CALL DB2315(IMES,NBRAS)
9700  IRC = -1
      GO TO 9900
9800  IRC = NS
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD850905--DB2205
      SUBROUTINE DB2205(ISTRNG,ISTRT,LEN,IZAHL,IRC)
      DIMENSION ISTRNG(*)
      IZAHL = 0
      IF(ISTRT .LE. 0) CALL DB9999(6,2205,1)    !added '6,' to these AWH
      IF(LEN .LE. 0) CALL DB9999(6,2205,2)
      DO 400 J = ISTRT,LEN
      CALL CONVCI(ISTRNG,J,IZIF)
      IF(IZIF .GE. 0) GO TO 300
      IRC = J
      RETURN
300   IZAHL = IZAHL*10 + IZIF
400   CONTINUE
      IRC = LEN + 1
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2206
      SUBROUTINE DB2206(ID,LD,IDZ,LDZ,NBRAS,
     1MNAR,ISBADR,IRETC)
      INTEGER DB2210
      DIMENSION IDSCR(8),INBUF(16),ITFULL(32),ITLEN(32),NBRAS(*),ID(*),
     1NU(16),IDZ(*),MNAR(*)
      DIMENSION LOFFT(5)
       DIMENSION IXPX(1),JUNKX(1)
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2227/ IBTMAX,IBITT(64)
      DATA INBMAX/64/, ITYP/0/, ITSLN/0/
      DATA LOFFT/1,1,2,3,2/, MAXTYP/5/
      IVER = IFLAG(5)
      NPRINT = IFLAG(16)
      IRETC = 1
      ISBADR = 0
      LISBIN = 0
      IDBCB = IFLAG(40)
      LENDKB = MNAR(IDBCB)
      LENDKH = MNAR(IDBCB+1)
      IACTBS = MNAR(IDBCB+3)
      IMES = 88
      IF(IACTBS .EQ. 0) GO TO 9400
      IBSP = IDBCB + LENDKH
      LWSUM = 0
      DO 60 J = 1,IACTBS
      JUNK = IBSP + (J-1)*LENDKB + 131
      LENWO = MNAR(JUNK)
60    LWSUM = LWSUM + LENWO
      LISLEN = LWSUM + LWSUM/2
      DO 4000 IBAS = 1,IACTBS
      IFOUND = 0
      NXTLVL = 1
      INFCBA = IBSP + 70
      INFP = MNAR(INFCBA)
      INFILE = MNAR(IBSP+65)
      IZUBIT = MNAR(IBSP+66)
      IZUWRD = IZUBIT/32
      IF(MNAR(INFCBA+5) .NE. 1) GO TO 100
      CALL CHRINT(ID,1,1,KLASSE)
      INFP = MNAR(INFCBA+KLASSE+19)
      IF(INFP .EQ. 0) GO TO 3900
100   INFPLS = -1
      J = DB2210(0)
  200 CONTINUE
      IF(INFP .LE. INFPLS) GO TO 9010
      INFPLS = INFP
      LAD = 12
      CALL DB0101(INFILE,INFP,INBUF,0,LAD,NBRAS)
      CALL CHRINT(INBUF,1,1,ITYP)
      IF(ITYP .GT. MAXTYP) GO TO 800
      IF(ITYP .EQ. 0) GO TO 9001
      IHDR = 1
      GO TO(300,400,500,520,540),ITYP
  300 ITSLN = 1
      ITSPOS = 4
      IADD = 3
      GO TO 700
  400 CALL CHRINT(INBUF,4,1,ITSLN)
      ITSPOS = 5
      IADD = 4
      GO TO 600
  500 ITSLN = 1
      ITSPOS = 5
      IADD = 4
      GO TO 700
  520 ITSLN = 1
      ITSPOS = 6
      IADD = 5
      GO TO 700
  540 CALL CHRINT(INBUF,5,1,ITSLN)
      ITSPOS = 6
      IADD = 5
      GO TO 600
  600 IBIS = ITSPOS + ITSLN -1
      IF(IBIS .LE. LAD) GO TO 700
      IF(IBIS .GT. 64) GO TO 9003
      CALL DB0101(INFILE,INFP+LAD,INBUF,LAD,IBIS-LAD,NBRAS)
      LAD = IBIS
  700 LSTEP = IADD + ITSLN
      GO TO 1500
  800 IF(ITYP .GT. 131) GO TO 1300
      IF(ITYP .LT. 129) GO TO 9005
      ITP = ITYP - 128
      IHDR = 0
      INFQ = INFP
      CALL CHRINT(INBUF,2,1,ITSLN)
      IF(ITSLN .EQ. 0) GO TO 1000
      NACHLD = ITSLN + 7 - LAD
      IF(NACHLD .LE. 0) GO TO 1000
      IF(LAD + NACHLD .GT. INBMAX) GO TO 9006
      CALL DB0101(INFILE,INFP+LAD,INBUF,LAD,NACHLD,NBRAS)
      LAD = LAD + NACHLD
 1000 ITSPOS = 3
      LL = ITP
      CALL CHRINT(INBUF,3+ITSLN,LL,IZREF)
      INFQ = INFQ + 2 + ITSLN + LL
      INFPA = INFQ
      IF(ITP .EQ. 3) GO TO 1100
      INFQ = INFQ + 3*IZREF
      GO TO 1200
1100  CALL CHRINT(INBUF,6+ITSLN,2,LBTS)
      INFQ = INFQ + 2 + LBTS
 1200 LSTEP = INFQ - INFP
      GO TO 1500
 1300 IF(ITYP .NE. 254) GO TO 1400
      NXTLVL = LVL - 1
      IF(NXTLVL .LT. 1) GO TO 9008
      LVL = NXTLVL
      INFP = INFP + 1
      GO TO 200
 1400 IF(ITYP .NE. 255) GO TO 9009
      GO TO 3900
1500  LVL = NXTLVL
      IF(ITSLN .EQ. 0) GO TO 1520
      IPOS2 = 1
      IF(LVL .GT. 1) IPOS2 = ITFULL(LVL-1) + 1
      IF(IPOS2 + ITSLN .GT. 33) GO TO 9004
      CALL COPYCH(INBUF,ITSPOS,ITSLN,IDSCR,IPOS2)
1520  IF(LVL .GT. 1) GO TO 1540
      ITFULL(LVL) = ITSLN
      GO TO 1560
1540  ITFULL(LVL) = ITFULL(LVL-1) + ITSLN
1560  ITLEN(LVL) = ITSLN
      LGSTR = ITFULL(LVL)
      IF(IFOUND .EQ. 1) GO TO 1900
      IEHIT = 0
      LVG = MIN0(LD,LGSTR)
      IF(LVG .EQ. 0) GO TO 1800
      IF(LCOMP(ID,IDSCR,LVG)) 1700,1600,1800
1600  IF(IHDR .EQ. 0) GO TO 1640
      IF(LD - LGSTR) 1700,2500,2500
1640  IF(LD - LGSTR .GT. 0) GO TO 2500
1700  IFOUND = 1
      GO TO 1900
1800  IF(IHDR) 2500,2500,3000
1900  LVG = MIN0(LDZ,LGSTR)
      IF(LVG .EQ. 0) GO TO 2000
      IF(LCOMP(IDSCR,IDZ,LVG))  2000,1920,3900
1920  IF(IHDR .EQ. 1) GO TO 1960
      IF(LGSTR - LDZ) 2000,1940,3900
1940  IEHIT = 1
      GO TO 2000
1960  IF(LGSTR .GT. LDZ) GO TO 3900
2000  IF(IHDR .EQ. 1) GO TO 2600
      IF(ITP .EQ. 3) GO TO 2240
      IF(LISBIN) 2080,2040,2220
2040  CALL DB2219(2206,2040)
      CALL DB2231(MNAR,4+LISLEN,LISADR)
      IF(LISADR+1) 9200,9220,2060
2060  LISFUL = 0
      LISNXT = LISADR+4
      ILFRST = LISADR + 4
      ILLAST = ILFRST + LISLEN - 1
      LISBIN = -1
2080  IF(LISFUL+IZREF .LE. LISLEN) GO TO 2100
      CALL DB2219(2206,2080)
      CALL DB2231(MNAR,4+LWSUM,NBIADR)
      IF(NBIADR+1) 9200,9220,2082
2082  JEND = NBIADR + LWSUM + 3
      DO 2085 J = NBIADR,JEND
2085  MNAR(J) = 0
      LISBIN = 1
      IBFRST = NBIADR + 4
      IBLAST = IBFRST + LWSUM - 1
      JAN = LISADR + 4
      JEND = JAN + LISFUL - 1
      DO 2087 J = JAN,JEND
      JUNK = MNAR(J)
      IWONR = JUNK/32
      IBIPOS = JUNK - 32*IWONR + 1
      JUNK2 = NBIADR + 4 + IWONR
      IF(JUNK2 .LT. IBFRST) GO TO 9011
      IF(JUNK2 .GT. IBLAST)  GO TO 9011
      MNAR(JUNK2) = LOR(MNAR(JUNK2),IBITT(IBIPOS))
2087  CONTINUE
      CALL DB2219(2206,2087)
      CALL DB2232(MNAR,LISADR,NRC)
      IF(NRC) 9200,2220,9200
2100  IPFILE = INFPA
      IF(LISNXT .GT. ILLAST) GO TO 9011
      IF(LISNXT .LT. ILFRST) GO TO 9011
      IF(LISNXT+IZREF-1 .GT. ILLAST) GO TO 9011
      DO 2120 J = 1,IZREF
      CALL DB0101(INFILE,IPFILE,IXPX(1),1,3,NBRAS)
      IXP = IXPX(1)
      IXPX(1) = IXP
      CALL CHRINT(IXPX(1),2,3,JUNK)
      MNAR(LISNXT) = JUNK + IZUBIT
      IPFILE = IPFILE+3
      LISNXT = LISNXT + 1
2120  CONTINUE
      LISFUL = LISFUL + IZREF
      GO TO 2350
2220  IPFILE = INFPA
      DO 2230 J = 1,IZREF
      CALL DB0101(INFILE,IPFILE,IXP,1,3,NBRAS)
      IXPX(1) = IXP
      CALL CHRINT(IXPX(1),2,3,JUNK)
      JUNK = JUNK + IZUBIT
      IWONR = JUNK/32
      IBIPOS = JUNK - 32*IWONR + 1
      JUNK2 = NBIADR + 4 + IWONR
      IF(JUNK2 .LT. IBFRST) GO TO 9011
      IF(JUNK2 .GT. IBLAST) GO TO 9011
      MNAR(JUNK2) = LOR(MNAR(JUNK2),IBITT(IBIPOS))
      IPFILE = IPFILE + 3
2230  CONTINUE
      GO TO 2350
2240  CONTINUE
      IF(LISBIN) 2310,2260,2290
2260  CALL DB2219(2206,2260)
      CALL DB2231(MNAR,4+LWSUM,NBIADR)
      IF(NBIADR+1) 9200,9220,2270
2270  JEND = NBIADR + LWSUM + 3
      DO 2280 J = NBIADR,JEND
2280  MNAR(J) = 0
      LISBIN = 1
      IBFRST = NBIADR+4
      IBLAST = IBFRST + LWSUM - 1
2290  LBTSD4 = LBTS/4
      IPFILE = INFPA + 2
      IAMZU = IZUWRD + NBIADR + 4
      IF(IAMZU .LT. IBFRST) GO TO 9011
      IF(IAMZU .GT. IBLAST) GO TO 9011
      IF(IAMZU+LBTSD4-1 .GT. IBLAST) GO TO 9011
      DO 2300 J = 1,LBTSD4
      CALL DB0101(INFILE,IPFILE,JUNKX(1),0,4,NBRAS)
      JUNK = JUNKX(1)
      JUNKX(1) = JUNK
      MNAR(IAMZU) = LOR(MNAR(IAMZU),JUNKX(1))
      IAMZU = IAMZU + 1
      IPFILE = IPFILE + 4
2300  CONTINUE
      GO TO 2350
2310  CALL DB2219(2206,2310)
      CALL DB2231(MNAR,4+LWSUM,NBIADR)
      IF(NBIADR+1) 9200,9220,2320
2320  JEND = NBIADR + LWSUM + 3
      DO 2325 J = NBIADR,JEND
2325  MNAR(J) = 0
      LISBIN = 1
      IBFRST = NBIADR + 4
      IBLAST = IBFRST + LWSUM  - 1
      JAN = LISADR + 4
      JEND = JAN + LISFUL - 1
      DO 2330 J = JAN,JEND
      JUNK = MNAR(J)
      IWONR = JUNK/32
      IBIPOS = JUNK - 32*IWONR + 1
      JUNK2 = NBIADR + 4 + IWONR
      IF(JUNK2 .GT. IBLAST) GO TO 9011
      IF(JUNK2 .LT. IBFRST) GO TO 9011
      MNAR(JUNK2) = LOR(MNAR(JUNK2),IBITT(IBIPOS))
2330  CONTINUE
      CALL DB2219(2206,2330)
      CALL DB2232(MNAR,LISADR,NRC)
      IF(NRC) 9200,2290,9200
2350  IF(IFLAG(6) .EQ. 0) GO TO 2500
 2395 IF(DB2210(1) .NE. 0) GO TO 4060
      IHMSAD = 1
      LHMSTB = 300
      CALL DB2207(IDSCR,LGSTR,NU,NULEN,NPRINT,MNAR(IHMSAD),LHMSTB)
      CALL CICDC(NU,1,NULEN*4)
      WRITE(NPRINT,2400) IZREF,(NU(J),J=1,NULEN)
 2400 FORMAT(1X,I6,' * ',16A4)
2500  IF(IEHIT .EQ. 1) GO TO 3900
2600  NXTLVL = LVL
      IF(IHDR .EQ. 1) NXTLVL = NXTLVL + 1
      IF(NXTLVL .GT. 32) GO TO 9002
      INFP = INFP + LSTEP
      GO TO 200
3000  NXTLVL = LVL
      LOFF = LOFFT(ITYP)
      CALL CHRINT(INBUF,2,LOFF,IOFFS)
      INFP = INFP + IOFFS
      GO TO 200
3900  IBSP = IBSP + LENDKB
4000  CONTINUE
4060  IF(LISBIN) 4100,4300,4200
4100  MNAR(LISADR) = 1
      MNAR(LISADR+1) = LISFUL
      MNAR(LISADR+2) = 0
      MNAR(LISADR+3) = 0
      CALL DB2219(2206,4100)
      CALL DB2234(MNAR,LISFUL+4,LISADR,IRR)
      IF(IRR .LT. 0) GO TO 9200
      ISBADR = LISADR
      GO TO 9800
4200  MNAR(NBIADR) = 0
      MNAR(NBIADR+1) = LWSUM
      MNAR(NBIADR+2) = -1
      MNAR(NBIADR+3) = 0
      ISBADR = NBIADR
      GO TO 9800
4300  CALL DB2219(2206,4300)
      CALL DB2231(MNAR,4,ISBADR)
      IF(ISBADR+1) 9200,9220,4400
4400  MNAR(ISBADR) = 1
      MNAR(ISBADR+1) = 0
      MNAR(ISBADR+2) = 0
      MNAR(ISBADR+3) = 0
      GO TO 9800
 9001 ICD = 1
      GO TO 9100
 9002 ICD = 2
      GO TO 9100
 9003 ICD = 3
      GO TO 9100
 9004 ICD = 4
      GO TO 9100
 9005 ICD = 5
      GO TO 9100
 9006 ICD = 6
      GO TO 9100
 9008 ICD = 8
      GO TO 9100
 9009 ICD = 9
      GO TO 9100
 9010 ICD = 10
      GO TO 9100
 9011 ICD = 11
      GO TO 9100
 9100 WRITE(NPRINT,9120) INFP,ICD
 9120 FORMAT(' DB2206 - ERROR IN INV. FILE (ADDRESS=',I9,'  CODE=',I2,
     1')')
      IRETC = 2
      GO TO 9800
 9200 IRETC = 4
      GO TO 9300
 9220 IRETC = 3
      GO TO 9800
9300  CONTINUE
9400  CALL DB2315(IMES,NBRAS)
      IRETC = 5
9800  CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD870317--DB2207
      SUBROUTINE DB2207(NDS,LEN,NU,NULEN,NPRINT,IHMSTB,LHMSTB)
      PARAMETER (IZKL=30)
      DIMENSION NDS(*),NU(*),NAMSYM(IZKL),IZIF(10),MINKL(2),ISYMB(3)
      DIMENSION IHMSTB(*)
       DIMENSION IBLAR(1),IGLEIX(1),NELSYX(1),IHX(1),ICRUX(1)
CHP8  DATA NSMAX/IZKL/, IBLANK/'    '/, IH/'    '/, IGLEI/'='/,
C    1ICLASS/0/, IPLUS/'+'/, MINUS/'-'/, IPUNKT/'.'/, IFRAG/'??? '/,
C    2MINKL/'-','-'/, ICR/'R'/, ICU/'U'/
Cmw      DATANSMAX/IZKL/,IBLANK/Z'40404040'/,IH/Z'40404040'/,IGLEI/Z'7E4040
Cmw     $40'/,ICLASS/0/,IPLUS/Z'4E404040'/,MINUS/Z'60404040'/,IPUNKT/Z'4B40
Cmw     $4040'/,IFRAG/Z'6F6F6F40'/,MINKL/Z'60404040',Z'60404040'/,ICR/Z'D94
Cmw     $04040'/,ICU/Z'E4404040'/
      DATANSMAX/IZKL/,IBLANK/Z'40404040'/,IH/Z'40404040'/,IGLEI/Z'404040
     $7E'/,ICLASS/0/,IPLUS/Z'4040404E'/,MINUS/Z'40404060'/,IPUNKT/Z'4040
     $404B'/,IFRAG/Z'406F6F6F'/,MINKL/Z'40404060',Z'40404060'/,ICR/Z'404
     $040D9'/,ICU/Z'404040E4'/
CHP8  DATA IBLAR(1)/'    '/, IGLEIX(1)/'='/
Cmw      DATAIBLAR(1)/Z'40404040'/,IGLEIX(1)/Z'7E404040'/
      DATAIBLAR(1)/Z'40404040'/,IGLEIX(1)/Z'4040407E'/
      DATA INT2/2/
CHP8  DATA NAMSYM/'COL ','ELE ','ELE ','ELE ','AUT ','MINR','TEST',
C    1     'YEAR','CODN','REM ','ELC ','REL ','RVAL','ELE ','D   ',
C    2     'CVOL','SGR ','SGR ','SYST','CLAS','LAUE','SYPR','ANX ',
C    3     'PRS' ,'FRAG','RFCD','CHCL','DATE','Z   ','STAT'/
Cmw      DATANAMSYM/Z'C3D6D340',Z'C5D3C540',Z'C5D3C540',Z'C5D3C540',Z'C1E4E
Cmw     $340',Z'D4C9D5D9',Z'E3C5E2E3',Z'E8C5C1D9',Z'C3D6C4D5',Z'D9C5D440',Z
Cmw     $'C5D3C340',Z'D9C5D340',Z'D9E5C1D3',Z'C5D3C540',Z'C4404040',Z'C3E5D
Cmw     $6D3',Z'E2C7D940',Z'E2C7D940',Z'E2E8E2E3',Z'C3D3C1E2',Z'D3C1E4C5',Z
Cmw     $'E2E8D7D9',Z'C1D5E740',Z'D7D9E240',Z'C6D9C1C7',Z'D9C6C3C4',Z'C3C8C
Cmw     $3D3',Z'C4C1E3C5',Z'E9404040',Z'E2E3C1E3'/
      DATANAMSYM/Z'40D3D6C3',Z'40C5D3C5',Z'40C5D3C5',Z'40C5D3C5',Z'40E3E
     $4C1',Z'D9D5C9D4',Z'E3E2C5E3',Z'D9C1C5E8',Z'D5C4D6C3',Z'40D4C5D9',Z
     $'40C3D3C5',Z'40D3C5D9',Z'D3C1E5D9',Z'40C5D3C5',Z'404040C4',Z'D3D6E
     $5C3',Z'40D9C7E2',Z'40D9C7E2',Z'E3E2E8E2',Z'E2C1D3C3',Z'C5E4C1D3',Z
     $'D9D7E8E2',Z'40E7D5C1',Z'40E2D9D7',Z'C7C1D9C6',Z'C4C3C6D9',Z'D3C3C
     $8C3',Z'C5E3C1C4',Z'404040E9',Z'E3C1E3E2'/
CHP8  DATA IZIF/'0','1','2','3','4','5','6','7','8','9'/
Cmw      DATAIZIF/Z'F0404040',Z'F1404040',Z'F2404040',Z'F3404040',Z'F440404
Cmw     $0',Z'F5404040',Z'F6404040',Z'F7404040',Z'F8404040',Z'F9404040'/
      DATAIZIF/Z'404040F0',Z'404040F1',Z'404040F2',Z'404040F3',Z'404040F
     $4',Z'404040F5',Z'404040F6',Z'404040F7',Z'404040F8',Z'404040F9'/
      IF(LEN .LT. 1) GO TO 9000
      IF(LEN .GT. 32) GO TO 9000
      IZAHL = 0
      NDEZ = 0
      ASSIGN 8000 TO NRET
      CALL CHRINT(NDS,1,1,ICLASS)
      IF(ICLASS .GT. NSMAX) GO TO 9040
      IF(ICLASS .LE. 0) GO TO 9040
      NU(1) = NAMSYM(ICLASS)
      NU(INT2) = IBLANK
      DO 300 J = 1,4
      IF(LCOMPS(NU,J,1,IBLAR(1),1) .EQ. 0) GO TO 320
      JP = J
300   CONTINUE
320   JP = JP + 1
      CALL COPYCH(IGLEIX(1),1,1,NU,JP)
      IF (LEN .EQ. 1) GO TO 8000
      GO TO(400,600,600,600,800,800,1000,1100,800,1200,1100,
     18000,1300,600,1400,1600,1700,1100,1800,1900,1900,2100,2200,
     2800,800,800,1100,2400,1100,1100     ),ICLASS
400   CALL CHRINT(NDS,2,3,IZAHL)
      GO TO 7000
600   CALL CHRINT(NDS,2,1,IZAHL)
      IF(IZAHL .GT. 0) GO TO 620
      NELSYM = IFRAG
      GO TO 630
620   CALL DB2013(IZAHL,NELSYM)
630   NELSYX(1) = NELSYM
      DO 640 J = 1,4
      IF(LCOMPS(NELSYX(1),J,1,IBLAR(1),1) .EQ. 0) GO TO 660
      JP = JP + 1
      CALL COPYCH(NELSYX(1),J,1,NU,JP)
640   CONTINUE
660   IF(ICLASS .NE. 3) GO TO 700
      IZAHL = 0
      CALL CHRINT(NDS,3,1,IZAHL)
      IZAHL = (IZAHL - 80) * 5
      IH = IPLUS
      IF (IZAHL .LT. 0) IH = MINUS
      JP = JP + 1
      IHX(1) = IH
      CALL COPYCH(IHX(1),1,1,NU,JP)
      IZAHL = IABS(IZAHL)
      NDEZ = 2
      GO TO 7000
700   IF (ICLASS .NE. 14) GO TO 8000
      IZAHL = 0
      CALL CHRINT(NDS,3,1,IZAHL)
      IZAHL1 = 0
      CALL CHRINT(NDS,4,1,IZAHL1)
      IZAHL = IZAHL*10 + IZAHL1
      NDEZ = 1
      GO TO 7000
800   CALL COPYCH(NDS,2,LEN-1,NU,JP+1)
      JP = JP + LEN - 1
      GO TO 8000
1000  CALL CHRINT(NDS,2,1,IZAHL)
      ASSIGN 1020 TO NRET
      GO TO 7000
1020  ASSIGN 8000 TO NRET
      IZAHL = 0
      CALL CHRINT(NDS,3,1,IZAHL)
      GO TO 7000
1100  CALL CHRINT(NDS,2,1,IZAHL)
      GO TO 7000
1200  CALL CHRINT(NDS,2,1,IZAHL)
      CALL DB2019(IZAHL,IRSYM)
      CALL COPYCH(IRSYM,1,4,NU,JP+1)
      JP = JP + 4
      GO TO 8000
1300  CALL CHRINT(NDS,2,1,IZAHL)
      NDEZ = 3
      GO TO 7000
1400  DO 1540 J = 1,2
      NELSYM = IFRAG
      IZAHL = 0
      CALL CHRINT(NDS,J+1,1,IZAHL)
      IF(IZAHL .GT. 0) CALL DB2013(IZAHL,NELSYM)
      NELSYX(1) = NELSYM
      DO 1460 J1 = 1,4
      IF(LCOMPS(NELSYX(1),J1,1,IBLAR(1),1) .EQ. 0) GO TO 1500
      JP = JP + 1
1460  CALL COPYCH(NELSYX(1),J1,1,NU,JP)
1500  JP = JP + 1
      CALL COPYCH(MINKL(J),1,1,NU,JP)
1540  CONTINUE
      IZAHL = 0
      CALL CHRINT(NDS,4,1,IZAHL)
      IZAHL = IZAHL * 2
      NDEZ = 2
      GO TO 7000
1600  CALL CHRINT(NDS,2,1,IZAHL)
      IZAHL = IZAHL * IZAHL
      GO TO 7000
1700  CALL COPYCH(NDS,2,8,NU,JP+1)
      JP = JP + 8
      GO TO 8000
1800  CALL COPYCH(NDS,2,3,NU,JP+1)
      JP = JP + 3
      GO TO 8000
1900  CALL COPYCH(NDS,2,5,NU,JP+1)
      JP = JP + 5
      GO TO 8000
2100  CALL COPYCH(NDS,2,4,NU,JP+1)
      JP = JP + 4
      GO TO 8000
2200  LENM2 = LEN - 2
      CALL COPYCH(NDS,3,LENM2,NU,JP+1)
      JP = JP + LENM2
      GO TO 8000
2400  JP = JP + 1
      ICRU = ICR
      CALL CHRINT(NDS,2,3,IZAHL)
      IF(IZAHL .LT. 1000000) GO TO 2440
      ICRU = ICU
      IZAHL = IZAHL - 1000000
2440  ICRUX(1) = ICRU
      CALL COPYCH(ICRUX(1),1,1,NU,JP)
      GO TO 7000
7000  IZA = IZAHL
      ISTELL = NDEZ + 1
7060  IZA1 = 10**ISTELL
      IF(IZA / IZA1 .EQ. 0) GO TO 7100
      ISTELL = ISTELL + 1
      GO TO 7060
7100  DO 7300 JFL = 1,ISTELL
      IZA1 = IZA1 / 10
      IZD = IZA / IZA1
      JP = JP + 1
      CALL COPYCH(IZIF(IZD+1),1,1,NU,JP)
      IZA = MOD(IZA,IZA1)
      IF(JFL - (ISTELL-NDEZ)) 7300, 7140, 7180
7140  IF(IZA .EQ. 0) GO TO 7400
      JP = JP + 1
      CALL COPYCH(IPUNKT,1,1,NU,JP)
      GO TO 7300
7180  IF(IZA .EQ. 0) GO TO 7400
7300  CONTINUE
7400  GO TO NRET, (1020,8000)
8000  CONTINUE
      CALL COPYCH(IBLAR(1),1,4,NU,JP+1)
      NULEN = (JP-1)/4 + 1
      GO TO 9900
9000  WRITE(NPRINT,9020) LEN
9020  FORMAT(' DB220701 - DESCRIPTOR HAS ILL. LENGTH',I6)
      GO TO 9880
9040  WRITE(NPRINT,9060) ICLASS
9060  FORMAT(' DB220702 - ILL. DESCRIPTOR CLASS',I4)
9880  NULEN = 1
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD850815--DB2208
      SUBROUTINE DB2208(ISTRNG,ISTRT,LEN,ZAHL,IRC)
      DIMENSION ISTRNG(*)
       INTEGER IH(1)
CHP8  DATA IH(1)/'    '/, IPUNKT/'.   '/
Cmw      DATAIH(1)/Z'40404040'/,IPUNKT/Z'4B404040'/
      DATAIH(1)/Z'40404040'/,IPUNKT/Z'4040404B'/
      CALL DB2205(ISTRNG,ISTRT,LEN,IVK,IRC)
      IF(IRC .GE. LEN) GO TO 300
      CALL COPYCH(ISTRNG,IRC,1,IH(1),1)
      IF(IH(1) .NE. IPUNKT) GO TO 300
      IST = IRC + 1
      CALL DB2205(ISTRNG,IST,LEN,INK,IRC)
      ZAHL = FLOAT(IVK) + (FLOAT(INK)/FLOAT(10**(IRC-IST)))
      RETURN
300   ZAHL = FLOAT(IVK)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD870120--DB2209
      SUBROUTINE DB2209(LINMAX,LINPUT)
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2209/ LINC,LINMA,LPRN,LNPUT,ISKIP
      LINC = 0
      LINMA = LINMAX
      LPRN = IFLAG(16)
      LNPUT = LINPUT
      ISKIP = 0
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850814--DB2210
      INTEGER FUNCTION DB2210(N)
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2209/ LINC,LINMA,LPRN,LNPUT,ISKIP
      DIMENSION IRESP(5)
       DIMENSION ICYX(1),ICNX(1),IBLAR(1)
CHP8  DATA ICY/'Y'/, ICN/'N'/, IBLANK/' '/
Cmw      DATAICY/Z'E8404040'/,ICN/Z'D5404040'/,IBLANK/Z'40404040'/
      DATAICY/Z'404040E8'/,ICN/Z'404040D5'/,IBLANK/Z'40404040'/
CHP8  DATA ICYX(1)/'Y'/, ICNX(1)/'N'/, IBLAR(1)/' '/
Cmw      DATAICYX(1)/Z'E8404040'/,ICNX(1)/Z'D5404040'/,IBLAR(1)/Z'40404040'
      DATAICYX(1)/Z'404040E8'/,ICNX(1)/Z'404040D5'/,IBLAR(1)/Z'40404040'
     $/
      DB2210 = 0
      IF(N .EQ. 0) LINC = 0
      LINC = LINC + N
      IF(LINC .LT. LINMA-1) GO TO 9000
      LINC = 0
60    IF(IFLAG(32) .NE. 0) GO TO 9000
      WRITE(LPRN,100)
100   FORMAT(' ... more (Y/N)?')
      CALL KEYBRD(LNPUT,IRESP,5)
      ISKIP = 0
      ISTAT = 1
      IVORZ = 1
      IYES = 1
      DO 200 J = 1,20
      IF(LCOMPS(IRESP,J,1,IBLAR(1),1) .EQ. 0) GO TO 200
      IF(ISTAT-2) 110,130,150
110   IF(LCOMPS(IRESP,J,1,ICYX(1),1) .EQ. 0) GO TO 120
      IF(LCOMPS(IRESP,J,1,ICNX(1),1) .NE. 0) GO TO 260
      IYES = 0
120   ISTAT = 2
      GO TO 200
130   CALL CONVCI(IRESP,J,IZIF)
      IF(IZIF .NE. -3) GO TO 140
      IVORZ = -1
      ISTAT = 3
      GO TO 200
140   IF(IZIF .LT. 0) GO TO 260
      ISKIP = IZIF
      ISTAT = 3
      GO TO 200
150   CALL CONVCI(IRESP,J,IZIF)
      IF(IZIF .EQ.-1) GO TO 210
      IF(IZIF .LT. 0) GO TO 260
      ISKIP = ISKIP*10 + IZIF
200   CONTINUE
210   ISKIP = ISKIP * IVORZ
      IF(IYES .NE. 1) GO TO 240
      IF(IFLAG(37) .EQ. 0) CALL CLEAR
      GO TO 9000
240   IF(IYES .EQ. 0) GO TO 400
260   WRITE(LPRN,300)
300   FORMAT(' Invalid response')
      GO TO 60
400   DB2210 = 1
9000  CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2211
      SUBROUTINE DB2211(MNAR,IADR,MODUS,
     1ICATEG,LCATEG,IRC,NBRAS,ARMN)
      INTEGER   MNAR(*),ICATEG(*),LIREL(10),NBRAS(*),ICASYM(21)
      REAL      ARMN(*)
      DIMENSION LINE(64),IGK(6),IGKL(6),IHAR(2),LINEH(18),NDPP(3)
      DIMENSION CELL(6),IZIF(10),ISSU(2),NCEN(2),FINE(40)
       INTEGER IBLANX(1),IPUNKX(1),KOMBLX(1),KLAUFX(1),KLAZUX(1)
       INTEGER IVGLX(1),IZGLX(1),IDGLX(1),NULLX(1),KLA19X(1)
       INTEGER KLAPX(1),MINUSX(1),IBKLAX(1),NOPKX(1),IVORZX(1)
       INTEGER ISAVE(1),IZSX(1),ICD1X(1),ICD2X(2),ISOTYX(1)
       INTEGER IGLEIX(1)
       REAL ZLX(1)
      INTEGER NELIST(25),ITAR(4)
      REAL FLIST(25)
      DIMENSION LINCDC(18)
      INTEGER DB2210
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2206/ ICSDCB(64),ITABCB(64),ICS2CB(64)
      COMMON /DC2209/ LINC,LINMA,LPRN,LNPUT,ISTIP
      COMMON /DC2011/ IELSYM(106),IREFPT(107),MNEMO(35),IREF(392)
      EQUIVALENCE(LINE(1),FINE(1))
CHP8  DATA LINEH/'    ','    ','    ','    ','    ','    ','    ',
C    1    '    ','    ','    ','    ','    ','    ','    ','    ',
C    2    '    ','    ','    '/
      DATALINEH/Z'40404040',Z'40404040',Z'40404040',Z'40404040',Z'404040
     $40',Z'40404040',Z'40404040',Z'40404040',Z'40404040',Z'40404040',Z'
     $40404040',Z'40404040',Z'40404040',Z'40404040',Z'40404040',Z'404040
     $40',Z'40404040',Z'40404040'/
      DATA ICAMAX/21/, MXFREE/65/, MXELC/25/
CHP8  DATA ICASYM/'NAME','RFCD','MINR','FORM','TITL','REF ','AUT ',
C    1     'CELL','SGR ','SYM ','TYPE','PARM','BETA','BIJ ','UIJ ',
C    2     'REM ','CAS ','RVAL','PICT','TEST','ITF '/
Cmw      DATAICASYM/Z'D5C1D4C5',Z'D9C6C3C4',Z'D4C9D5D9',Z'C6D6D9D4',Z'E3C9E
Cmw     $3D3',Z'D9C5C640',Z'C1E4E340',Z'C3C5D3D3',Z'E2C7D940',Z'E2E8D440',Z
Cmw     $'E3E8D7C5',Z'D7C1D9D4',Z'C2C5E3C1',Z'C2C9D140',Z'E4C9D140',Z'D9C5D
Cmw     $440',Z'C3C1E240',Z'D9E5C1D3',Z'D7C9C3E3',Z'E3C5E2E3',Z'C9E3C640'/
      DATAICASYM/Z'C5D4C1D5',Z'C4C3C6D9',Z'D9D5C9D4',Z'D4D9D6C6',Z'D3E3C
     $9E3',Z'40C6C5D9',Z'40E3E4C1',Z'D3D3C5C3',Z'40D9C7E2',Z'40D4E8E2',Z
     $'C5D7E8E3',Z'D4D9C1D7',Z'C1E3C5C2',Z'40D1C9C2',Z'40D1C9E4',Z'40D4C
     $5D9',Z'40E2C1C3',Z'D3C1E5D9',Z'E3C3C9D7',Z'E3E2C5E3',Z'40C6E3C9'/
CHP8  DATA ICHCL/'CHCL'/
Cmw      DATAICHCL/Z'C3C8C3D3'/
       DATAICHCL/Z'D3C3C8C3'/
CHP8  DATA IBLANX(1)/'    '/, IPUNKX(1)/'.'/, KOMBLX(1)/',   '/,
C    1KLAUFX(1)/'('/, KLAZUX(1)/')'/, IVGLX(1)/' V='/, IZGLX(1)/' Z='/,
C    2IDGLX(1)/' D='/, NULLX/'0'/, KLA19X(1)/'(19'/, KLAPX(1)/') P.'/,
C    3MINUSX/'-'/, NOPKX(1)/'NO. '/, IBKLAX(1)/' ('/, ISOTYX(1)/'    '/
Cmw      DATAIBLANX(1)/Z'40404040'/,IPUNKX(1)/Z'4B404040'/,KOMBLX(1)/Z'6B40
Cmw     $4040'/,KLAUFX(1)/Z'4D404040'/,KLAZUX(1)/Z'5D404040'/,IVGLX(1)/Z'40
Cmw     $E57E40'/,IZGLX(1)/Z'40E97E40'/,IDGLX(1)/Z'40C47E40'/,NULLX/Z'F0404
Cmw     $040'/,KLA19X(1)/Z'4DF1F940'/,KLAPX(1)/Z'5D40D74B'/,MINUSX/Z'604040
Cmw     $40'/,NOPKX(1)/Z'D5D64B40'/,IBKLAX(1)/Z'404D4040'/,ISOTYX(1)/Z'4040
Cmw     $4040'/
      DATAIBLANX(1)/Z'40404040'/,IPUNKX(1)/Z'4040404B'/,KOMBLX(1)/Z'4040
     $406B'/,KLAUFX(1)/Z'4040404D'/,KLAZUX(1)/Z'4040405D'/,IVGLX(1)/Z'40
     $7EE540'/,IZGLX(1)/Z'407EE940'/,IDGLX(1)/Z'407EC440'/,NULLX/Z'40404
     $0F0'/,KLA19X(1)/Z'40F9F14D'/,KLAPX(1)/Z'4BD7405D'/,MINUSX/Z'404040
     $60'/,NOPKX(1)/Z'404BD6D5'/,IBKLAX(1)/Z'40404D40'/,ISOTYX(1)/Z'4040
     $4040'/
CHP8  DATA IGLEIX(1)/'='/
Cmw      DATAIGLEIX(1)/Z'7E404040'/
       DATAIGLEIX(1)/Z'4040407E'/
CHP8  DATA IBLANK/'    '/, KOMBLK/',   '/, KLAUF/'('/, KLAZU/')'/,
C    1IZGL/' Z='/, IDGL/' D='/, IPLUS/'+'/, MINUS/'-'/, IPUNKT/'.'/,
C    2NULL/'0'/, KLA19/'(19'/, KLAP/') P.'/, ISOTYP/'    '/, ICB/'B'/,
C    3ICU/'U'/, ICL/'L'/, IGLEI/'='/, IVGL/' V='/, ICSMAT/'SMAT'/,
C    4FAK/0.017453/, ICJRNL/'JRNL'/, ISSU/'ISSU','E'/,
C    5IBKLA/' ('/, NOPK/'NO. '/, NCEN/'NCEN',' CEN'/, ICSTAT/'STAT'/
Cmw      DATAIBLANK/Z'40404040'/,KOMBLK/Z'6B404040'/,KLAUF/Z'4D404040'/,KLA
Cmw     $ZU/Z'5D404040'/,IZGL/Z'40E97E40'/,IDGL/Z'40C47E40'/,IPLUS/Z'4E4040
Cmw     $40'/,MINUS/Z'60404040'/,IPUNKT/Z'4B404040'/,NULL/Z'F0404040'/,KLA1
Cmw     $9/Z'4DF1F940'/,KLAP/Z'5D40D74B'/,ISOTYP/Z'40404040'/,ICB/Z'C240404
Cmw     $0'/,ICU/Z'E4404040'/,ICL/Z'D3404040'/,IGLEI/Z'7E404040'/,IVGL/Z'40
Cmw     $E57E40'/,ICSMAT/Z'E2D4C1E3'/,FAK/0.017453/,ICJRNL/Z'D1D9D5D3'/,ISS
Cmw     $U/Z'C9E2E2E4',Z'C5404040'/,IBKLA/Z'404D4040'/,NOPK/Z'D5D64B40'/,NC
Cmw     $EN/Z'D5C3C5D5',Z'40C3C5D5'/,ICSTAT/Z'E2E3C1E3'/
      DATAIBLANK/Z'40404040'/,KOMBLK/Z'4040406B'/,KLAUF/Z'4040404D'/,KLA
     $ZU/Z'4040405D'/,IZGL/Z'407EE940'/,IDGL/Z'407EC440'/,IPLUS/Z'404040
     $4E'/,MINUS/Z'40404060'/,IPUNKT/Z'4040404B'/,NULL/Z'404040F0'/,KLA1
     $9/Z'40F9F14D'/,KLAP/Z'4BD7405D'/,ISOTYP/Z'40404040'/,ICB/Z'404040C
     $2'/,ICU/Z'404040E4'/,ICL/Z'404040D3'/,IGLEI/Z'4040407E'/,IVGL/Z'40
     $7EE540'/,ICSMAT/Z'E3C1D4E2'/,FAK/0.017453/,ICJRNL/Z'D3D5D9D1'/,ISS
     $U/Z'E4E2E2C9',Z'404040C5'/,IBKLA/Z'40404D40'/,NOPK/Z'404BD6D5'/,NC
     $EN/Z'D5C5C3D5',Z'D5C5C340'/,ICSTAT/Z'E3C1E3E2'/
      DATA LLENPR/18/, LLENRF/11/, LLENIS/8/
CHP8  DATA IGK/'A=',' B=',' C=',' AL=',' BE=',' GA='/
Cmw      DATAIGK/Z'C17E4040',Z'40C27E40',Z'40C37E40',Z'40C1D37E',Z'40C2C57E
Cmw     $',Z'40C7C17E'/
      DATAIGK/Z'40407EC1',Z'407EC240',Z'407EC340',Z'7ED3C140',Z'7EC5C240
     $',Z'7EC1C740'/
      DATA IGKL/2,   3,    3,    4,     4,     4/
      DATA NDPP/3,4,3/
CHP8  DATA IZIF/'0','1','2','3','4','5','6','7','8','9'/
Cmw      DATAIZIF/Z'F0404040',Z'F1404040',Z'F2404040',Z'F3404040',Z'F440404
Cmw     $0',Z'F5404040',Z'F6404040',Z'F7404040',Z'F8404040',Z'F9404040'/
      DATAIZIF/Z'404040F0',Z'404040F1',Z'404040F2',Z'404040F3',Z'404040F
     $4',Z'404040F5',Z'404040F6',Z'404040F7',Z'404040F8',Z'404040F9'/
      DATA FDEZ/1000.0/, IDIG/100000/, NSTG/3/, MXCO/7/
      IZIEL = 1
      IACT = 0
      IFL18 = IFLAG(18)
      NDEV = IFLAG(32)
      NPORT = IFLAG(33)
      ISMAT = IFLAG(43)
      ITFLGS = IFLAG(48)
      ICADR = 0
      ITYPAR = 0
      LNGA = 0
      IRC = 0
      IVER = IFLAG(5)
      IDBCB = IFLAG(40)
      KFIRST = IDBCB + MNAR(IDBCB+1)
      LENDKB = MNAR(IDBCB)
      IACTBS = MNAR(IDBCB+3)
      IF(MODUS .EQ. 1) GO TO 200
      MAXCTG = 0
      IF(LCATEG .EQ. 0) GO TO 70
      DO 60 J = 1,LCATEG
      IF(ICATEG(J) .LE. MAXCTG) GO TO 60
      MAXCTG = ICATEG(J)
   60 CONTINUE
   70 IF(ISMAT .EQ. 0) GO TO 80
      MAXCTG = MAX0(MAXCTG,10)
      CALL DB2231(MNAR,12*48,NRC)
      IF(NRC .LE. 0) GO TO 7600
      MATSMX = NRC
   80 IF(IADR .LE. 0) GO TO 7835
      IF(IFLAG(35) .EQ. 0) GO TO 200
      CALL DB0128(3,IDIR,ITMADR,ITMLEN,ITABCB,NBRAS)
      IF(ITMLEN .LT. 64) GO TO 180
      CALL DB2313(2,1,MNAR,NBRAS,ICADR,ICLEN,IRETCD)
      IRETCD = IRETCD + 3
      GO TO (7700,7600,160,180), IRETCD
160   NCCODN = ICLEN / 5
      IF(NCCODN .GT. 0) GO TO 200
180   IFLAG(35) = 0
  200 CALL DB2221(MNAR,IADR,1,IREL)
      IRCNT = 0
      LIP = 0
      J = DB2210(0)
  300 CALL DB2221(MNAR,IADR,0,IREL)
      IRCNT = IRCNT + 1
      IF(IREL .EQ. 0) GO TO 7800
      IF(IRCNT - IZIEL) 300,301,200
301   IACT = IACT + 1
      IF(MODUS .EQ. 1) GO TO 7100
      IF(IACTBS .GT. 0) GO TO 304
      CALL DB2315(88,NBRAS)
      GO TO 7800
304   JP = KFIRST
      DO 302 JBAS = 1,IACTBS
      IZUG = MNAR(JP+66)
      IF (IREL .LE. (IZUG + MNAR(JP+130))) GO TO 305
      JP = JP + LENDKB
302   CONTINUE
      GO TO 7800
305   ICSX = MNAR(JP+64)
      CALL DB2250(IREL-IZUG,IZREC,MNAR(JP),NBRAS,IRETCD)
      IF(IRETCD .NE. 0) GO TO 6900
360   CALL DB2262(LINE)
      IF (ITFLGS .EQ. 1) THEN
         DO 380 J = 1,4
380      ITAR(J) = LINE(J)
      END IF
      LNGB = 3*IZREC + 60
      IF(LNGB .LE. LNGA) GO TO 500
      IF(LNGA .EQ. 0) GO TO 400
      CALL DB2219(2211,399)
      CALL DB2232(MNAR,ITYPAR,NRC)
      IF(NRC .NE. 0) GO TO 7700
400   CALL DB2219(2211,400)
      CALL DB2231(MNAR,LNGB,NRC)
      IF(NRC .LE. 0) GO TO 7600
      ITYPAR = NRC
      LNGA = LNGB
  500 CALL DB2261(MNAR(ITYPAR),LNGB,NBRAS,IRETCD,MAXCTG)
      IF(IRETCD .GE. 0) GO TO 580
      IF(DB2210(1) .NE. 0) GO TO 7320
      WRITE(NPORT,540) IREL
  540 FORMAT(' DB2211 - INVALID DATA IN REL=',I10)
      GO TO 7350
  580 IF(DB2210(2) .NE. 0) GO TO 7320
      JUNK1 = INVDAT(LINE(5))
      JUNK2 = INVDAT(LINE(6))
      WRITE(NPORT,600) IRETCD,JUNK1,JUNK2,IREL,IZIEL
  600 FORMAT(1X,/,' **** COLLECTION CODE COL=',I6,
     1' (DATE=R',I6,'/U',I6,' REL=',I6,'/',I6,')')
      J = 0
      IF (IRETCD .GE. 500000) J = 3
      IF (IRETCD .GE. 700000) J = 2
      IF (IRETCD .GE. 800000) J = 1
      IFLAG(36) = J
      IF (IFLAG(36) .NE. 3) THEN
         DO 620 J = 1,4
         IF(LINE(J) .GT. 1) GO TO 620
         IF(LINE(J) .EQ. 0) GO TO 640
         IF(J .GE. 2) GO TO 640
  620    CONTINUE
         GO TO 680
  640    CONTINUE
         IF(DB2210(1) .NE. 0) GO TO 7320
         WRITE(NPORT,660)
  660    FORMAT(' ---- WARNING: ENTRY NOT YET TESTED COMPLETELY.',
     1   ' MAY CONTAIN ERRORS. ----')
      END IF
  680 IF(LCATEG .LE. 0) GO TO 6805
      DO 6800 JC = 1,LCATEG
      NTYP = ICATEG(JC)
      IF(NTYP .GT. ICAMAX) GO TO 6600
      IF(NTYP .EQ. 21) GO TO 6505
      CALL DB2257(MNAR(ITYPAR),NTYP,IZ)
      IF(IZ .EQ. 0) GO TO 6800
      ICA = ICASYM(NTYP)
      IF(NTYP .NE. 11) GO TO 690
      IF(IFLAG(36) .NE. 1) GO TO 690
      ICA = ICHCL
  690 JT = 1
  700 CALL DB2252(NTYP,JT,MNAR(ITYPAR),NBRAS,NR)
      IF(NR .LE. 0) GO TO 6800
      GO TO( 1000,1000,1000,1000,1000,4300,1600,1900,6210,6000,
     1     1000,2700,4700,4700,4700,1000,1000,6200,1000,6205), NTYP
 1000 CALL DB2255(1,IAFELD,LFELD)
      IF(LFELD .EQ. 0) GO TO 6500
      LBRZ = 0
 1100 LBR1 = IAFELD + LBRZ
      LBRS = MIN0(MXFREE,LFELD-LBRZ)
      ISKIP = 0
      CALL DB2317(ICSX,LBR1,LINE,0,LBRS,NBRAS)
      IF(LBRZ+LBRS .EQ. LFELD) GO TO 1400
      IBS = LBRS
 1200 IF(LCOMPS(IBLANX(1),1,1,LINE,IBS) .EQ. 0) GO TO 1300
      IBS = IBS - 1
      IF(IBS) 1400,1400,1200
 1300 LBRS = IBS - 1
      ISKIP = 1
 1400 CALL COPYCH(IBLANX(1),1,3,LINE,LBRS+1)
      JEND = (LBRS+3)/4
      IF(DB2210(1) .NE. 0) GO TO 7320
      CALL CICDC(ICA,1,4)
      CALL CICDC(LINE,1,4*JEND)
      WRITE(NPORT,1500) ICA, (LINE(J),J=1,JEND)
 1500 FORMAT(1X,A4,1X,16A4,A1)
      ICA = IBLANK
      LBRZ = LBRZ + LBRS + ISKIP
      IF(LBRZ .LT. LFELD) GO TO 1100
      IF(NTYP .NE. 4) GO TO 6500
      IF(JT .GT. 1) GO TO 6500
      CALL DB0101(ICSX,IAFELD,LINE,0,LFELD,NBRAS)
      CALL DB2337(LINE,LFELD,NELIST,FLIST,MXELC,NELCNT)
      IF(NELCNT .LE. 0) GO TO 6500
      CALL COPYCH(IGLEIX(1),1,2,LINE,1)
      LINFUL = 2
      DO 1550 JELE = 1,NELCNT
      IZAHL = FLIST(JELE)*FDEZ + 0.5
      IF(IZAHL .LE. 0) GO TO 1550
      IDUM = NELIST(JELE)
      LINFUL = LINFUL + 1
      CALL COPYCH(IELSYM(IDUM),1,2,LINE,LINFUL)
      IF(LCOMPS(LINE,LINFUL+1,1,IBLANX(1),1) .NE. 0) LINFUL = LINFUL + 1
      IBSK = 1
      IDI = IDIG
      NSTCNT = NSTG
1522  IZAD = IZAHL / IDI
      IF(IZAD .GT. 0) GO TO 1525
      IF(IBSK .NE. 0) GO TO 1527
1525  IBSK = 0
      LINFUL = LINFUL + 1
      CALL COPYCH(IZIF(IZAD+1),1,1,LINE,LINFUL)
1527  IZAHL = IZAHL - IZAD*IDI
      IF(NSTCNT .GT. 1) GO TO 1530
      IF(IZAHL .EQ. 0) GO TO 1535
      IBSK = 0
      IF(NSTCNT .NE. 1) GO TO 1530
      LINFUL = LINFUL+1
      CALL COPYCH(IPUNKT,1,1,LINE,LINFUL)
1530  NSTCNT = NSTCNT - 1
      IDI = IDI / 10
      GO TO 1522
1535  LINFUL = LINFUL + 1
      CALL COPYCH(IBLANX(1),1,1,LINE,LINFUL)
      IF(JELE .GE. NELCNT) GO TO 1540
      IF(LINFUL .LE. (MXFREE-MXCO)) GO TO 1550
1540  IF(DB2210(1) .NE. 0) GO TO 7320
      CALL COPYCH(IBLANX(1),1,4,LINE,LINFUL+1)
      JEND = (LINFUL+3) / 4
      CALL CICDC(LINE,1,4*JEND)
      WRITE(NPORT,1545) (LINE(J),J=1,JEND)
1545  FORMAT(6X,16A4,A1)
      LINFUL = 2
      LINE(1) = IBLANK
1550  CONTINUE
      GO TO 6500
 1600 CALL DB2255(1,IAFELD,LFELD)
 1700 IFULL = 0
      IF(IFULL+LFELD .GT. MXFREE-2) GO TO 7400
 1800 CALL DB2317(ICSX,IAFELD,LINE,IFULL,LFELD,NBRAS)
      IFULL = LFELD + IFULL
      IF(JT .EQ. IZ) GO TO 6300
      CALL COPYCH(KOMBLX(1),1,4,LINE,IFULL+1)
      IFULL = IFULL + 2
      JT = JT + 1
      CALL DB2252(NTYP,JT,MNAR(ITYPAR),NBRAS,NR)
      CALL DB2255(1,IAFELD,LFELD)
      IF(IFULL+LFELD .LE. MXFREE-2) GO TO 1800
      JEND = (IFULL+2) / 4
      IF(DB2210(1) .NE. 0) GO TO 7320
      CALL CICDC(ICA,1,4)
      CALL CICDC(LINE,1,4*JEND)
      WRITE(NPORT,1500) ICA,(LINE(J),J=1,JEND)
      ICA = IBLANK
      GO TO 1700
 1900 JZ2 = 1
      IFULL = 0
      DO 2100 JZ = 1,6
      CALL COPYCH(IGK(JZ),1,IGKL(JZ),LINE,IFULL+1)
      IFULL = IFULL + IGKL(JZ)
      CALL DB2255(JZ2,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 2000
      CALL DB2317(ICSX,IAFELD,LINE,IFULL,LFELD,NBRAS)
      CALL DB2208(LINE,IFULL+1,IFULL+LFELD,CELL(JZ),IDUM)
      IFULL = IFULL + LFELD
      CALL DB2255(JZ2+1,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 2000
      IFULL = IFULL + 1
      CALL COPYCH(KLAUFX(1),1,1,LINE,IFULL)
      CALL DB2317(ICSX,IAFELD,LINE,IFULL,LFELD,NBRAS)
      IFULL = IFULL + LFELD + 1
      CALL COPYCH(KLAZUX(1),1,1,LINE,IFULL)
 2000 JZ2 = JZ2 + 2
 2100 CONTINUE
      COSA = COS(CELL(4) * FAK)
      COSB = COS(CELL(5) * FAK)
      COSC = COS(CELL(6) * FAK)
      ARG = 1.0 + 2.0*COSA*COSB*COSC - COSA*COSA - COSB*COSB - COSC*COSC
      IF(ARG .LT. 0.0) GO TO 2180
      CVOL = CELL(1) * CELL(2) * CELL(3) * SQRT(ARG)
      IVOL = CVOL*10.0 + 0.5
      CALL COPYCH(IVGLX(1),1,3,LINE,IFULL+1)
      IFULL = IFULL + 3
      JD = 1000000
      IZFL = 0
      DO 2160 J = 1,7
      IF(J .EQ. 6) IZFL = 1
      JZF = IVOL / JD
      IF(JZF .GT. 0) GO TO 2120
      IF(IZFL .EQ. 0) GO TO 2140
2120  IZFL = 1
      IFULL = IFULL + 1
      CALL COPYCH(IZIF(JZF+1),1,1,LINE,IFULL)
2140  IVOL = IVOL - JZF*JD
      JD = JD / 10
      IF(J .NE. 6) GO TO 2160
      IFULL = IFULL + 1
      CALL COPYCH(IPUNKX(1),1,1,LINE,IFULL)
2160  CONTINUE
2180  CONTINUE
      IF (IFLAG(36) .NE. 3) THEN
         CALL DB2255(13,IAFELD,LFELD)
         IF(LFELD .LE. 0) GO TO 2200
         IF(IAFELD .EQ. 0) GO TO 2200
         CALL COPYCH(IZGLX(1),1,3,LINE,IFULL+1)
         IFULL = IFULL + 3
         CALL DB2317(ICSX,IAFELD,LINE,IFULL,LFELD,NBRAS)
         IFULL = IFULL + LFELD
      END IF
 2200 CALL DB2255(14,IAFELD,LFELD)
      IF(LFELD .EQ. 0) GO TO 2300
      CALL COPYCH(IDGLX(1),1,3,LINE,IFULL+1)
      IFULL = IFULL + 3
      CALL DB2317(ICSX,IAFELD,LINE,IFULL,LFELD,NBRAS)
      IFULL = IFULL + LFELD
      CALL DB2255(15,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 2300
      IFULL = IFULL + 1
      CALL COPYCH(KLAUFX(1),1,1,LINE,IFULL)
      CALL DB2317(ICSX,IAFELD,LINE,IFULL,LFELD,NBRAS)
      IFULL = IFULL + LFELD + 1
      CALL COPYCH(KLAZUX(1),1,1,LINE,IFULL)
 2300 CALL COPYCH(IBLANX(1),1,3,LINE,IFULL+1)
      IF(IFULL .LE. MXFREE) GO TO 6400
      IBS = MXFREE
      DO 2400 J = 1,MXFREE
      IF(LCOMPS(LINE,IBS,1,IBLANX(1),1) .EQ. 0) GO TO 2500
      IBS = IBS - 1
 2400 CONTINUE
 2500 CALL COPYCH(LINE,IBS+1,2,ISAVE(1),1)
      CALL COPYCH(IBLANX(1),1,2,LINE,IBS+1)
      JEND = (IBS+2)/4
      IF(DB2210(1) .NE. 0) GO TO 7320
      CALL CICDC(ICA,1,4)
      CALL CICDC(LINE,1,4*JEND)
      WRITE(NPORT,1500) ICA,(LINE(J),J=1,JEND)
      ICA = IBLANK
      CALL COPYCH(ISAVE(1),1,2,LINE,IBS+1)
      JAN = IBS + 1
      JEND = IFULL + 3
      JG = 0
      DO 2600 J = JAN,JEND
      JG = JG + 1
      CALL COPYCH(LINE,J,1,LINE,JG)
 2600 CONTINUE
      IFULL = JG - 3
      GO TO 6400
 2700 DO 2800 J = 1,LLENPR
 2800 LINE(J) = IBLANK
      IHFLG = 0
      IF(JT .GT. 1) GO TO 3000
      IF(DB2210(2) .NE. 0) GO TO 7320
      WRITE(NPORT,2900)
 2900 FORMAT(/,' At   Nr Ox     Wy  ---- x ----    ---- y ----  ',
     1'  ---- z ----   SOF')
 3000 CALL DB2255(1,IAFELD,LFELD)
      LFELD = MIN0(LFELD,2)
      IF(LFELD .LE. 0) GO TO 6500
      CALL DB2317(ICSX,IAFELD,LINE,1,LFELD,NBRAS)
      IP = LFELD + 1
      CALL DB2255(18,IAFELD,LFELD)
      IF(LFELD .NE. 1) GO TO 3100
      CALL DB2317(ICSX,IAFELD,LINE,IP,1,NBRAS)
      CALL DB2317(ICSX,IAFELD-1,LINE,IP+1,1,NBRAS)
 3100 CALL DB2255(2,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 6500
      IF(LFELD .GT. 3) GO TO 6500
      CALL DB2317(ICSX,IAFELD,LINE,8-LFELD,LFELD,NBRAS)
      CALL DB2255(3,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 6500
      IP = 1
      IVORZ = IPLUS
      CALL DB2317(ICSX,IAFELD,IHAR,0,8,NBRAS)
c      IF(LCOMP(MINUSX(1),IHAR,1) .NE. 0) GO TO 3200    !AWH 20/10/97
      IF(LCOMP(MINUSX(1),IHAR,IP) .NE. 0) GO TO 3200    !AWH don't pass constant to Solaris
      IVORZ = MINUS
      IP = 2
 3200 IVORZX(1) = IVORZ
      CALL COPYCH(IVORZX(1),1,1,LINE,10)
      IPK = IP
      DO 3300 J = IP,LFELD
      IF(LCOMPS(IPUNKX(1),1,1,IHAR,J) .EQ. 0) GO TO 3400
      IPK = IPK + 1
 3300 CONTINUE
      GO TO 3500
 3400 CALL COPYCH(IPUNKX(1),1,1,LINE,12)
 3500 IF(IPK .GT. IP) GO TO 3600
      CALL COPYCH(NULLX(1),1,1,LINE,11)
      GO TO 3700
 3600 CALL COPYCH(IHAR,IP,1,LINE,11)
 3700 IF(IPK .GE. LFELD) GO TO 3800
      CALL COPYCH(IHAR,IPK+1,LFELD-IPK,LINE,13)
 3800 CALL DB2255(6,IAFELD,LFELD)
      IF(LFELD .EQ. 0) GO TO 3900
      CALL DB2255(4,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 3840
      IF(LFELD .GT. 3) GO TO 3840
      CALL DB2317(ICSX,IAFELD,LINE,17-LFELD,LFELD,NBRAS)
      CALL DB2255(5,IAFELD,LFELD)
      CALL DB2317(ICSX,IAFELD,LINE,17,1,NBRAS)
3840  CALL DB2214(ICSX, 6,LINE,LINEH,20,15,3,IHFLG,NBRAS)
      CALL DB2214(ICSX, 8,LINE,LINEH,35,15,3,IHFLG,NBRAS)
      CALL DB2214(ICSX,10,LINE,LINEH,50,15,3,IHFLG,NBRAS)
      CALL DB2214(ICSX,15,LINE,LINEH,65,6,2,IHFLG,NBRAS)
      GO TO 5700
 3900 CALL DB2259(4,ZLX(1),IRZ,NBRAS)
      ZL = ZLX(1)
      IF(IRZ .LT. 0) GO TO 5700
      CALL DB2259(15,ZLX(1),IRZ,NBRAS)
      SOF = ZLX(1)
      IF(IRZ + 1) 5700,4000,4100
 4000 SOF = 1.0
 4100 Z = ZL * SOF
      IF(DB2210(1) .NE. 0) GO TO 7320
      CALL CICDC(LINE,1,16)
      WRITE(NPORT,4200) (LINE(J),J=1,4), Z
 4200 FORMAT(4A4,F6.2,' Atoms not located in unit cell')
      GO TO 6500
 4300 DO 4400 J = 1,LLENRF
 4400 LINE(J) = IBLANK
      IPQ = 0
      CALL DB2255(2,IAFELD,LFELD)
      CALL DB2317(ICSX,IAFELD,LINE,IPQ,5,NBRAS)
      IPQ = IPQ + 6
      CALL DB2255(3,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 4460
      CALL DB2317(ICSX,IAFELD,LINE,IPQ,LFELD,NBRAS)
      IPQ = IPQ + LFELD + 1
 4460 CALL DB2255(7,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 4500
      CALL COPYCH(ISSU,1,5,LINE,IPQ+1)
      IPQ = IPQ + 6
      CALL DB2317(ICSX,IAFELD,LINE,IPQ,LFELD,NBRAS)
      IPQ = IPQ + LFELD + 1
 4500 CALL COPYCH(KLA19X(1),1,3,LINE,IPQ+1)
      IPQ = IPQ + 3
      CALL DB2255(1,IAFELD,LFELD)
      CALL DB2317(ICSX,IAFELD,LINE,IPQ,2,NBRAS)
      IPQ = IPQ + 2
      CALL COPYCH(KLAPX(1),1,4,LINE,IPQ+1)
      IPQ = IPQ + 5
      IZS = IBLANK
      CALL DB2255(6,IAFELD,LFELD)
      IF(LFELD .NE. 1) GO TO 4540
      CALL DB2317(ICSX,IAFELD,IZSX(1),0,1,NBRAS)
      IZS= IZSX(1)
      CALL COPYCH(IZSX(1),1,1,LINE,IPQ+1)
      IPQ = IPQ + 1
 4540 CALL DB2255(4,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 4600
      CALL DB2317(ICSX,IAFELD,LINE,IPQ,LFELD,NBRAS)
      IPQ = IPQ + LFELD
      IF(IFLAG(36) .EQ. 1) GO TO 4600
      IF(IFLAG(36) .EQ. 3) GO TO 4600
      CALL COPYCH(MINUSX(1),1,1,LINE,IPQ+1)
      IPQ = IPQ + 1
      IF(IZS .EQ. IBLANK) GO TO 4560
      IZSX(1) = IZS
      CALL COPYCH(IZSX(1),1,1,LINE,IPQ+1)
      IPQ = IPQ + 1
 4560 CALL DB2255(5,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 4600
      CALL DB2317(ICSX,IAFELD,LINE,IPQ,LFELD,NBRAS)
      IPQ = IPQ + 5
 4600 IF(DB2210(1) .NE. 0) GO TO 7320
      CALL CICDC(ICA,1,4)
      CALL CICDCS(LINE,1,4*LLENRF,LINCDC)
      WRITE(NPORT,1500) ICA, (LINCDC(J),J=1,LLENRF)
      IF(IFLAG(35) .EQ. 0) GO TO 6500
      IUN = 1
      IOB = NCCODN
      IMITM = 0
      ICAL = ICJRNL
4605  IMIT = (IUN + IOB) / 2
      IF(IMIT .EQ. IMITM) GO TO 6500
      IMITM = IMIT
      IF(LCOMPS(LINE,1,5,MNAR(ICADR),IMIT*5-4)) 4615,4625,4610
4610  IUN = IMIT + 1
      GO TO 4620
4615  IOB = IMIT - 1
4620  IF(IUN - IOB) 4605,4605,6500
4625  IMIT = IMIT - 1
      IF(IMIT .LE. 0) GO TO 4630
      IF(LCOMPS(LINE,1,5,MNAR(ICADR),IMIT*5-4) .EQ. 0) GO TO 4635
4630  IMIT = IMIT + 1
4635  CALL DB2317(IFLAG(21),ITMADR+(IMIT-1)*64,LINE,8,64,NBRAS)
      IF(DB2210(1) .NE. 0) GO TO 7320
      CALL CICDC(ICAL,1,4)
      CALL CICDC(LINE(3),1,64)
      WRITE(NPORT,1500) ICAL,(LINE(J),J=3,18)
      ICAL = IBLANK
      IMIT = IMIT + 1
      IF(IMIT .GT. NCCODN) GO TO 6500
      IF(LCOMPS(LINE,1,5,MNAR(ICADR),IMIT*5-4)) 6500,4635,6500
 4700 DO 4800 J = 1,LLENPR
 4800 LINE(J) = IBLANK
      IHFLG = 0
      IF(JT .GT. 1) GO TO 5500
      IF(DB2210(2) .NE. 0) GO TO 7320
      IF(NTYP - 14) 4900,5100,5300
 4900 WRITE(NPORT,5000)
 5000 FORMAT(/,' Atom      Beta(1,1) Beta(2,2) Beta(3,3)',
     1' Beta(1,2) Beta(1,3) Beta(2,3)')
      GO TO 5500
 5100 WRITE(NPORT,5200)
 5200 FORMAT(/,' Atom       B(1,1)    B(2,2)    B(3,3)',
     1'    B(1,2)    B(1,3)    B(2,3)')
      GO TO 5500
 5300 WRITE(NPORT,5400)
 5400 FORMAT(/,' Atom       U(1,1)    U(2,2)    U(3,3)',
     1'    U(1,2)    U(1,3)    U(2,3)')
 5500 CALL DB2255(1,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 6500
      CALL DB2317(ICSX,IAFELD,LINE,1,LFELD,NBRAS)
      CALL DB2255(2,IAFELD,LFELD)
      IF(LFELD .LT. 0) GO TO 6300
      IF(LFELD .GT. 3) GO TO 6300
      CALL DB2317(ICSX,IAFELD,LINE,7-LFELD,LFELD,NBRAS)
      J1 = 11
      DO 5600 J = 3,13,2
      CALL DB2214(ICSX,J,LINE,LINEH,J1,10,NDPP(NTYP-12),IHFLG,NBRAS)
      J1 = J1 + 10
 5600 CONTINUE
 5700 IF(DB2210(1) .NE. 0) GO TO 7320
      CALL CICDC(LINE,1,71)
      WRITE(NPORT,5800) (LINE(J),J=1,LLENPR)
 5800 FORMAT(17A4,A3)
      IF(IHFLG .EQ. 0) GO TO 6500
      IF(DB2210(1) .NE. 0) GO TO 7320
      CALL CICDC(LINEH,1,71)
      WRITE(NPORT,5800) (LINEH(J),J=1,LLENPR)
      DO 5900 J = 1,LLENPR
 5900 LINEH(J) = IBLANK
      GO TO 6500
 6000 IFULL = 0
      DO 6100 J = 1,3
      CALL DB2255(J,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 6300
      CALL DB2317(ICSX,IAFELD,LINE,IFULL,LFELD,NBRAS)
      IFULL = IFULL + LFELD
      IF(J .EQ. 3) GO TO 6300
      IFULL = IFULL + 1
      CALL COPYCH(KOMBLX(1),1,1,LINE,IFULL)
 6100 CONTINUE
 6200 LINE(1) = IBLANK
      LINE(2) = IBLANK
      IFULL = 8
      CALL DB2214(ICSX,1,LINE,LINEH,1,8,3,IHFLG,NBRAS)
      GO TO 6400
 6205 N = 0
 6208 N = N + 1
      ICD1X(1) = IBLANK
      ICD2X(1) = IBLANK
      CALL DB2255(N,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 6500
      IF(LFELD .GT. 4) GO TO 6401
      CALL DB2317(ICSX,IAFELD,ICD1X(1),0,LFELD,NBRAS)
      ICD1 = ICD1X(1)
      N = N + 1
      CALL DB2255(N,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 6401
      IF(LFELD .GT. 4) GO TO 6401
      CALL DB2317(ICSX,IAFELD,ICD2X(1),0,LFELD,NBRAS)
      ICD2 = ICD2X(1)
      CALL DB2215(ICD1,ICD2,LINE,JEND)
      IF(DB2210(1) .NE. 0) GO TO 7320
      ICASA = ICA
      CALL CICDC(ICA,1,4)
      CALL CICDC(LINE,1,4*JEND)
      WRITE(NPORT,1500) ICA,(LINE(J),J=1,JEND)
      ICA = ICASA
      GO TO 6208
6210  IFULL = 0
      CALL DB2255(1,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 6215
      CALL DB2317(ICSX,IAFELD,LINE,0,LFELD,NBRAS)
      IFULL = IFULL + LFELD
6215  IF(IFLAG(36) .NE. 1) GO TO 6300
      CALL COPYCH(IBKLAX(1),1,2,LINE,IFULL+1)
      IFULL = IFULL + 2
      CALL DB2255(2,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 6295
      CALL COPYCH(NOPKX(1),1,3,LINE,IFULL+1)
      IFULL = IFULL + 3
      CALL DB2317(ICSX,IAFELD,LINE,IFULL,LFELD,NBRAS)
      IFULL = IFULL + LFELD
      CALL DB2258(3,N,IRZ,NBRAS)
      IF(IRZ .LT. 0) GO TO 6295
      IF(N .LE. 0) GO TO 6295
      IF(N .GT. 2) GO TO 6295
      IFULL = IFULL + 1
      CALL COPYCH(KOMBLX(1),1,1,LINE,IFULL)
      CALL COPYCH(NCEN(N),1,4,LINE,IFULL+1)
      IFULL = IFULL + 4
6295  IFULL = IFULL + 1
      CALL COPYCH(KLAZUX(1),1,1,LINE,IFULL)
      GO TO 6300
 6300 CALL COPYCH(IBLANX(1),1,3,LINE,IFULL+1)
 6400 JEND = (IFULL+3) / 4
 6401 IF(DB2210(1) .NE. 0) GO TO 7320
      ICASAV = ICA
      CALL CICDC(ICA,1,4)
      CALL CICDC(LINE,1,4*JEND)
      WRITE(NPORT,1500) ICA,(LINE(J),J=1,JEND)
      ICA = ICASAV
      GO TO 6500
 6500 JT = JT + 1
      IF(JT - IZ) 700,700,6800
 6505 IAN = 0
      DO 6410 J = 13,15
      CALL DB2257(MNAR(ITYPAR),J,IAN1)
      IAN = IAN + IAN1
 6410 CONTINUE
      CALL DB2257(MNAR(ITYPAR),12,IAN1)
      IF(IAN1 .LE. 0) GO TO 6800
      IF(IAN .GE. IAN1) GO TO 6800
      DO 6420 JTF = 1,IAN1
      CALL DB2252(12,JTF,MNAR(ITYPAR),NBRAS,NR)
      IF(NR .LE. 0) GO TO 6800
      CALL DB2255(12,IAFELD,LFELD)
      IF(LFELD .NE. 1) GO TO 6420
      CALL DB2317(ICSX,IAFELD,ISOTYX(1),0,1,NBRAS)
      ISOTYP = ISOTYX(1)
      IF(ISOTYP .EQ. ICB) GO TO 6415
      IF(ISOTYP .EQ. ICU) GO TO 6415
      IF(ISOTYP .EQ. ICL) GO TO 6425
      GO TO 6420
 6415 DO 6416 J = 1,LLENIS
 6416 LINE(J) = IBLANK
      CALL DB2255(1,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 6420
      CALL DB2317(ICSX,IAFELD,LINE,1,LFELD,NBRAS)
      CALL DB2255(2,IAFELD,LFELD)
      IF(LFELD .LT. 0) GO TO 6420
      IF(LFELD .GT. 3) GO TO 6420
      CALL DB2317(ICSX,IAFELD,LINE,7-LFELD,LFELD,NBRAS)
      ISOTYX(1) = ISOTYP
      CALL COPYCH(ISOTYX(1),1,1,LINE,10)
      CALL COPYCH(IGLEIX(1),1,1,LINE,11)
      CALL DB2214(ICSX,13,LINE,LINEH,12,18,4,IHFLG,NBRAS)
      IF(DB2210(1) .NE. 0) GO TO 7320
      CALL CICDC(LINE,1,4*LLENIS)
      WRITE(NPORT,5800) (LINE(J),J=1,LLENIS)
6420  CONTINUE
      GO TO 6800
6425  IF(DB2210(1) .NE. 0) GO TO 7320
      WRITE(NPORT,6430)
 6430 FORMAT(6X,'TF''S DEPOSITED IN BRITISH LIBRARY')
      GO TO 6800
 6600 IF(DB2210(1) .NE. 0) GO TO 7320
      WRITE(NPORT,6700) NTYP
 6700 FORMAT(' ????  UNKNOWN CATEGORY',I6)
 6800 CONTINUE
 6805 IF(ISMAT .EQ. 0) GO TO 6830
c
c----Test auf HMS-Record (Typ 9)
      call db2257 (mnar(itypar),9,junk)
       if (junk .le. 0) go to 6830
c
      CALL DB2334(LINE,ARMN(MATSMX),NSYM,NBGTYP,MNAR,MNAR(ITYPAR),
     1            NBRAS,NRC)
      IF(NRC .NE. 0) GO TO 7350
      IF(NSYM .LE. 0) GO TO 7350
      JP1 = MATSMX
      ICA = ICSMAT
      ISPGRN = LINE(3)
      IF(ISPGRN .GT. 230) ISPGRN = ISPGRN/100
      DO 6820 J = 1,NSYM
      DO 6810 J1 = 1,12
      LINE(J1) = MNAR(JP1)
      JP1 = JP1 + 1
6810  CONTINUE
      IF(DB2210(1) .NE. 0) GO TO 7320
      ICASA = ICA
      CALL CICDC(ICASA,1,4)
      WRITE(NPORT,6815) ICASA,NBGTYP,(FINE(M),M=1,12),ISPGRN
6815  FORMAT(1X,A4,I3,1X,3(F8.5,3F4.0),I3)
      ICA = IBLANK
6820  CONTINUE
6830  IF (ITFLGS .EQ. 0) GO TO 7350
      IF (DB2210(1) .NE. 0) GO TO 7320
      ICASA = ICSTAT
      CALL CICDC(ICASA,1,4)
      WRITE(NPORT,6835) ICASA, (ITAR(J), J=1,4)
6835  FORMAT (1X,A4,4I2)
      GO TO 7350
 6900 IF(DB2210(1) .NE. 0) GO TO 7320
      WRITE(NPORT,7000) IREL
 7000 FORMAT(' REL=',I6,' not found.')
      GO TO 7350
 7100 IF(LIP .LT. 10) GO TO 7300
      IF(NDEV .EQ. 1) GO TO 7220
      IF(DB2210(1) .NE. 0) GO TO 7320
      WRITE(NPORT,7200) LIREL
 7200 FORMAT(10(1X,I6))
      GO TO 7260
 7220 WRITE(IFL18,7240) LIREL
 7240 FORMAT('01',10I7)
 7260 LIP = 0
 7300 LIP = LIP + 1
      LIREL(LIP) = IREL
      GO TO 7350
 7320 IF(ISTIP .EQ. 0) GO TO 7840
 7350 IZIEL = IZIEL + 1
      IF(ISTIP .GT. 0) IZIEL = ISTIP
      IZIEL = MAX0(IZIEL,1)
      ISTIP = 0
      GO TO 300
 7400 IRC = 4
      GO TO 7820
 7600 IRC = 1
      IF(NRC .EQ. -1) GO TO 7820
 7700 IRC = 2
      GO TO 7820
 7800 IF(IACT .EQ. 0) IRC = 5
 7820 IF(LIP .EQ. 0) GO TO 7840
      IF(NDEV .EQ. 1) GO TO 7830
      WRITE(NPORT,7200) (LIREL(J),J=1,LIP)
      GO TO 7840
 7830 WRITE(IFL18,7240) (LIREL(J),J=1,LIP)
 7835 CALL DB2315(72,NBRAS)
 7840 IF(IRC .EQ. 2) GO TO 7900
      IF(ISMAT .EQ. 0) GO TO 7860
      IFLAG(43) = 0
      CALL DB2232(MNAR,MATSMX,NRC)
      IF(NRC .NE. 0) GO TO 7700
      CALL DB2292(MNAR,NBRAS,LINE,-1,ARMN,J,0,J,NRC)
 7860 IF(ITYPAR .NE. 0) CALL DB2219(2211,7840)
      NRC = 0
      IF(ITYPAR .NE. 0) CALL DB2232(MNAR,ITYPAR,NRC)
      IF(NRC .NE. 0) GO TO 7700
      IF(ICADR .EQ. 0) GO TO 7900
      CALL DB2232(MNAR,ICADR,NRC)
      IF(NRC .NE. 0) GO TO 7700
 7900 CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2212
      SUBROUTINE DB2212(MNAR,IADR,ICATEG,LCATEG,IRC,NBRAS)
      DIMENSION MNAR(*),ICATEG(*),NBRAS(*),ICATFL(20),IFIELD(65),
     1FIELD(65)
      INTEGER LINE(16)
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2206/ ICSDCB(64),ITABCB(64),ICS2CB(64)
      EQUIVALENCE (IFIELD(1),FIELD(1))
CHP8  DATA ICTMAX/20/, IBLANK/'    '/,
C    1ISTERN/'****'/, FAK/0.017453/
      DATAICTMAX/20/,IBLANK/Z'40404040'/,ISTERN/Z'5C5C5C5C'/,FAK/0.01745
     $3/
      IRC = 0
      LNGA = 0
      ITYPAR = 0
      NPORT = IFLAG(33)
      ISMAT = IFLAG(43)
      KNRMX = 0
      IDBCB = IFLAG(40)
      IACTBS = MNAR(IDBCB+3)
      KFIRST = IDBCB + MNAR(IDBCB+1)
      LENDKB = MNAR(IDBCB)
      DO 200 J = 1,ICTMAX
200   ICATFL(J) = 0
      IF(ISMAT .EQ. 0) GO TO 300
      KNRMX = 10
      CALL DB2231(MNAR,12*48,NRC)
      IF(NRC .LE. 0) GO TO 9200
      MATSMX = NRC
300   IF(LCATEG .LE. 0) GO TO 500
      KNRMX = 0
      DO 400 J = 1,LCATEG
      ICATJ = ICATEG(J)
      IF(ICATJ .GT. 20) ICATJ = 12
      ICATFL(ICATJ) = 1
      KNRMX = MAX0(KNRMX,ICATJ)
400   CONTINUE
500   CALL DB2221(MNAR,IADR,1,IREL)
1000  CALL DB2221(MNAR,IADR,0,IREL)
      IF(IREL .EQ. 0) GO TO 9900
c
      if (iflag(15) .ne. 0) then
         if (mod (irel-1,20) .ne. 0) go to 1000
      end if
c
      IF(IACTBS .LE. 0) GO TO 9900
      JP = KFIRST
      DO 1100 JBAS = 1,IACTBS
      IZUG = MNAR(JP+66)
      IF(IREL .LE. (IZUG + MNAR(JP+130))) GO TO 1120
      JP = JP + LENDKB
1100  CONTINUE
      GO TO 9900
1120  ICSX = MNAR(JP+66)
      CALL DB2250(IREL-IZUG,IZREC,MNAR(JP),NBRAS,IRETCD)
      IF(IRETCD .NE. 0) GO TO 1000
      CALL DB2262 (LINE)
      LNGB = 3*IZREC + 60
      IF(LNGB .LE. LNGA) GO TO 1500
      IF(LNGA .EQ. 0) GO TO 1400
      CALL DB2219(2212,1300)
      CALL DB2232(MNAR,ITYPAR,NRC)
      IF(NRC .NE. 0) GO TO 9100
1400  CALL DB2219(2212,1400)
      CALL DB2231(MNAR,LNGB,NRC)
      IF (NRC .LE. 0) GO TO 9200
      ITYPAR = NRC
      LNGA = LNGB
1500  CALL DB2261(MNAR(ITYPAR),LNGB,NBRAS,IRETCD,KNRMX)
      IF(IRETCD .LT. 0) GO TO 9300
      WRITE(NPORT,1600) IRETCD,IREL,(LINE(N),N=1,4)
1600  FORMAT(' 0000  ',2I7,1X,4I2,50X)
      ICOL99 = IRETCD
      IF(LCATEG .EQ. 0) GO TO 8100
      DO 8000 NTYP = 1,KNRMX
      IF(ICATFL(NTYP) .EQ. 0) GO TO 8000
      CALL DB2257(MNAR(ITYPAR),NTYP,IZ)
      IF(IZ .EQ. 0) GO TO 8000
      DO 7800 JT = 1,IZ
      CALL DB2252(NTYP,JT,MNAR(ITYPAR),NBRAS,NR)
      IF(NR .LE. 0) GO TO 7800
      GO TO (2000,2000,2000,2000,2000,2400,2000,3000,2000,4000,2000,
     14300,5400,5400,5400,2000,2000,6000,2000,6200), NTYP
2000  CALL DB2260(1,IFIELD(1),256,LEN,NBRAS)
      IF(LEN .LE. 0) GO TO 7800
      CALL COPYCH(IBLANK,1,4,IFIELD,LEN+1)
      NRZL = (LEN+71)/72
      JAN = 1
      DO 2200 NRZ = 1,NRZL
      JEND = MIN0(JAN+17,(LEN+3)/4)
      IZFR = NRZL - NRZ
      CALL CICDC(IFIELD(JAN),1,(JEND-JAN+1)*4)
      WRITE(NPORT,2100) NTYP,IZFR,(IFIELD(J),J=JAN,JEND)
2100  FORMAT(1X,I2,'0',I1,3X,18A4)
      JAN = JAN + 18
2200  CONTINUE
      GO TO 7800
2400  CALL DB2258(1,IFIELD(1),IRK,NBRAS)
      IF(IRK+1) 7800,2420,2440
2420  IFIELD(1) = 0
2440  CALL DB2260(2,IFIELD(2),5,LEN,NBRAS)
      IF(LEN .EQ. 5) GO TO 2460
      IFIELD(2) = ISTERN
      IFIELD(3) = ISTERN
2460  CALL DB2258(3,IFIELD(4),IRK,NBRAS)
      IF(IRK+1) 7800,2480,2500
2480  IFIELD(4) = 0
2500  DO 2540 J = 4,5
      CALL DB2258(J,IFIELD(J+1),IRK,NBRAS)
      IF(IRK+1) 7800,2520,2540
2520  IFIELD(J+1) = 0
2540  CONTINUE
      CALL DB2260(6,IFIELD(7),1,LEN,NBRAS)
      IF(LEN .NE. 1) IFIELD(7) = IBLANK
      CALL DB2258(7,IFIELD(8),IRK,NBRAS)
      IF(IRK+1) 7800,2560,2570
2560  IFIELD(8) = 0
2570  CONTINUE
      CALL CICDC(IFIELD,5,5)
      CALL CICDC(IFIELD,25,1)
      WRITE(NPORT,2600) NTYP,(IFIELD(J),J=1,8)
2600  FORMAT(1X,I2,'00   ',I2,A4,A1,3I7,1X,A1,I4,38X)
      GO TO 7800
3000  IFP = 1
      DO 3110 JG = 1,12,2
      CALL DB2259(JG,X,IRK,NBRAS)
      IF(IRK+1) 7800,3060,3020
3020  FIELD(IFP) = X
      IFIELD(IFP+1) = -IRK
      CALL DB2258(JG+1,I,IRK,NBRAS)
      IF(IRK+1) 7800,3080,3040
3040  IFIELD(IFP+2) = I
      GO TO 3100
3060  FIELD(IFP) = -1.0
3080  IFIELD(IFP+1) = 0
      IFIELD(IFP+2) = -1
3100  IFP = IFP + 3
3110  CONTINUE
      CVOL = -1.0
      COSA = COS(FIELD(10) * FAK)
      COSB = COS(FIELD(13) * FAK)
      COSC = COS(FIELD(16) * FAK)
      ARG = 1.0 + 2.0*COSA*COSB*COSC - COSA*COSA - COSB*COSB - COSC*COSC
      IF(ARG .LT. 0.0) GO TO 3115
      CVOL = FIELD(1) * FIELD(4) * FIELD(7) * SQRT(ARG)
3115  CALL DB2258(13,IFIELD(19),IRK,NBRAS)
      IF(IRK+1) 7800,3120,3140
3120  IFIELD(13) = 0
3140  CALL DB2259(14,FIELD(20),IRK,NBRAS)
      IF(IRK+1) 7800,3200,3160
3160  IFIELD(21) = -IRK
      CALL DB2258(15,N,IRK,NBRAS)
      IF(IRK+1) 7800,3220,3180
3180  IFIELD(22) = N
      GO TO 3300
3200  FIELD(20) = -1.0
3220  IFIELD(21) = 0
      IFIELD(22) = -1
3300  WRITE(NPORT,3320) (FIELD(J),IFIELD(J+2),IFIELD(J+1),
     1J=1,18,3),IFIELD(19),FIELD(20),IFIELD(22),IFIELD(21),CVOL
3320  FORMAT('  800   ',3(F9.5,I4,'.E',I2),F7.3,I4,'.E',I2,6X,/,
     1'  810   ',2(F7.3,I4,'.E',I2),I3,F6.3,I4,'.E',I2,E11.5,14X)
      GO TO 7800
4000  DO 4020 J = 1,6
4020  IFIELD(J) = IBLANK
      DO 4100 J = 1,3
4100  CALL DB2260(J,IFIELD(2*J-1),8,LEN,NBRAS)
      CALL CICDC(IFIELD,1,24)
      WRITE(NPORT,4200) (IFIELD(J),J=1,6)
4200  FORMAT(' 1000   ',6A4,48X)
      GO TO 7800
4300  IFIELD(1) = IBLANK
      CALL DB2260(1,IFIELD(1),2,LEN,NBRAS)
      CALL DB2258(2,IFIELD(2),IRK,NBRAS)
      CALL DB2259(3,FIELD(3),IRK,NBRAS)
      CALL DB2258(4,IFIELD(4),IRK,NBRAS)
      CALL DB2260(5,IFIELD(5),1,LEN,NBRAS)
      IFP = 6
      DO 4800 JG = 6,11,2
      CALL DB2259(JG,X,IRK,NBRAS)
      IF(IRK + 1) 7800,4600,4400
4400  FIELD(IFP) = X
      IFIELD(IFP+1) = -IRK
      CALL DB2258(JG+1,I,IRK,NBRAS)
      IF(IRK + 1) 7800,4620,4500
4500  IFIELD(IFP+2) = I
      GO TO 4700
4600  FIELD(IFP) = -1.0
4620  IFIELD(IFP+1) = 0
      IFIELD(IFP+2) = -1
4700  IFP = IFP + 3
4800  CONTINUE
      CALL DB2260(12,IFIELD(15),1,LEN,NBRAS)
      IF(LEN .LE. 0) IFIELD(15) = IBLANK
      CALL DB2259(13,X,IRK,NBRAS)
      IF(IRK + 1) 7800,5040,4900
4900  FIELD(16) = X
      IFIELD(17) = -IRK
      CALL DB2258(14,I,IRK,NBRAS)
      IF(IRK + 1) 7800,5100,5000
5000  IFIELD(18) = I
      GO TO 5100
5040  FIELD(16) = -1.0
5060  IFIELD(17) = 0
      IFIELD(18) = -1
5100  CALL DB2259(15,X,IRK,NBRAS)
      IF(IRK + 1) 7800,5160,5120
5120  FIELD(19) = X
      IFIELD(20) = -IRK
      CALL DB2258(16,I,IRK,NBRAS)
      IF(IRK + 1) 7800,5180,5140
5140  IFIELD(21) = I
      GO TO 5200
5160  FIELD(19) = 1.0
5180  IFIELD(20) = 0
      IFIELD(21) = -1
5200  CALL DB2258(17,IFIELD(22),IRK,NBRAS)
      IF(IRK + 1) 7800,5220,5240
5220  IFIELD(22) = 0
5240  IFIELD(23) = IBLANK
      IF(IFIELD(22) .LE. 0) GO TO 5260
      CALL DB2260(18,IFIELD(23),1,LEN,NBRAS)
5260  CONTINUE
      CALL CICDC(IFIELD( 1),1,4)
      CALL CICDC(IFIELD( 5),1,4)
      CALL CICDC(IFIELD(15),1,4)
      CALL CICDC(IFIELD(23),1,4)
      WRITE(NPORT,5300) IFIELD(1),IFIELD(2),FIELD(3),IFIELD(4),
     1IFIELD(5),FIELD(6),IFIELD(8),IFIELD(7),FIELD(9),IFIELD(11),
     2IFIELD(10),FIELD(12),IFIELD(14),IFIELD(13),IFIELD(15),
     3FIELD(16),IFIELD(18),IFIELD(17),FIELD(19),IFIELD(21),IFIELD(20),
     4IFIELD(22),IFIELD(23)
5300  FORMAT(' 1200   ',A2,I3,F6.3,I3,A1,3(F8.5,I4,'.E',I2),9X,/,
     1' 1210   ',A1,E11.4,I4,'.E',I3,F7.4,I4,'.E',I2,I1,A1,34X)
      GO TO 7800
5400  IFIELD(1) = IBLANK
      CALL DB2260(1,IFIELD(1),2,LEN,NBRAS)
      CALL DB2258(2,IFIELD(2),IRK,NBRAS)
      IFP = 3
      DO 5700 JG = 3,14,2
      CALL DB2259(JG,X,IRK,NBRAS)
      IF(IRK + 1) 7800,5600,5500
5500  FIELD(IFP) = X
      IFIELD(IFP+1) = -IRK
      CALL DB2258(JG+1,I,IRK,NBRAS)
      IF(IRK + 1) 7800,5620,5540
5540  IFIELD(IFP+2) = I
      GO TO 5660
5600  FIELD(IFP) = -1.0
5620  IFIELD(IFP+1) = 0
      IFIELD(IFP+2) = -1
5660  IFP = IFP + 3
5700  CONTINUE
      CALL CICDC(IFIELD,1,2)
      WRITE(NPORT,5800) NTYP,IFIELD(1),IFIELD(2),
     1(FIELD(J),IFIELD(J+2),IFIELD(J+1),J=3,11,3),NTYP,
     2(FIELD(J),IFIELD(J+2),IFIELD(J+1),J=12,20,3)
5800  FORMAT(1X,I2,'00   ',A2,I3,3(E11.4,I4,'.E',I3),7X,/,
     11X,I2,'10   ',3(E11.4,I4,'.E',I3),12X)
      GO TO 7800
6000  CALL DB2259(1,X,IRK,NBRAS)
      IF(IRK .LT. 0) GO TO 7800
      WRITE(NPORT,6100) X
6100  FORMAT(' 1800   ',F9.5,63X)
      GO TO 7800
6200  JP = 0
      DO 6300 J = 1,36
      CALL DB2258(J,IFIELD(J),IRK,NBRAS)
      IF(IRK .LT. 0) GO TO 6340
      JP = J
6300  CONTINUE
6340  IF(JP .GT. 0) WRITE(NPORT,6360) (IFIELD(J),J=1,JP)
6360  FORMAT(' 2000   ',36I2)
      GO TO 7800
7800  CONTINUE
8000  CONTINUE
8100  IF(ISMAT .EQ. 0) GO TO 8500
c
c----Wenn nicht einmal das HMS vorhanden ist, enthaelt der Entry
c     keinerlei Symmetrie-Information.
      call db2257 (mnar(itypar),9,iz)
      if (iz .le. 0) go to 8500
c
      CALL DB2334(IFIELD,MNAR(MATSMX),NSYM,NBGTYP,MNAR,MNAR(ITYPAR),
     1            NBRAS,NRC)
      IF(NRC .NE. 0) GO TO 8500
      IF(NSYM .LE. 0) GO TO 8500
      JP1 = MATSMX
      ISPGRN = IFIELD(3)
      IF(ISPGRN .GT. 230) ISPGRN = ISPGRN/100
      DO 8300 J = 1,NSYM
      DO 8180 J1 = 1,12
      IFIELD(J1) = MNAR(JP1)
      JP1 = JP1 + 1
8180  CONTINUE
      NSC = NSYM - J
      WRITE(NPORT,8200) NSC,NBGTYP,(FIELD(M),M=1,12),ISPGRN
8200  FORMAT(' 240',I2,I3,1X,3(F8.5,3F4.0),I3)
8300  CONTINUE
8500  WRITE (NPORT,8520) ICOL99,IREL
8520  FORMAT (' 9900  ',2I7,59X)
      GO TO 1000
9100  IRC = 2
      GO TO 9990
9200  IRC = 1
      GO TO 9990
9300  IRC = 3
      GO TO 9900
9900  IF(ITYPAR .EQ. 0) GO TO 9920
      CALL DB2219(2212,9900)
      CALL DB2232(MNAR,ITYPAR,NRC)
      IF(NRC .NE. 0) GO TO 9100
9920  IF(ISMAT .EQ. 0) GO TO 9990
      IFLAG(43) = 0
      CALL DB2232(MNAR,MATSMX,NRC)
      IF(NRC .NE. 0) GO TO 9100
      CALL DB2292(MNAR,NBRAS,IFIELD,-1,MNAR,J,0,J,NRC)
9990  CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850905--DB2213
      SUBROUTINE DB2213(ICARD,ISTRT,LEN,IZAHL)
      DIMENSION ICARD(*)
      IZAHL = 0
      IP = ISTRT
      DO 300 J = 1,LEN
      CALL CONVCI(ICARD,IP,IZIF)
      IF(IZIF + 1) 400,100,200
100   IZIF = 0
200   IZAHL = IZAHL*10 + IZIF
      IP = IP + 1
300   CONTINUE
400   RETURN
      END
C ----------------------------------------OWNUNC411----UPD850815--DB2214
      SUBROUTINE DB2214(ICSD,IRFELD,LINE,LINEH,LINP,LENF,NDP,IHFLG,
     1                  NBRAS)
      DIMENSION IDUM(5),LINE(*),LINEH(*),NBRAS(*)
       INTEGER IPUNKT(1),ISTERN(1),IBLANK(1),MINULL(1)
       INTEGER MINUS(1),NULL(1),KLAUF(1),KLAZU(1)
CHP8  DATA IPUNKT(1)/'.'/, ISTERN(1)/'*'/,
C    1IBLANK(1)/'    '/, MINULL(1)/'-0'/,
C    2MINUS(1)/'-'/, NULL(1)/'0'/, KLAUF(1)/'('/, KLAZU(1)/')'/
Cmw      DATAIPUNKT(1)/Z'4B404040'/,ISTERN(1)/Z'5C404040'/,IBLANK(1)/Z'4040
Cmw     $4040'/,MINULL(1)/Z'60F04040'/,MINUS(1)/Z'60404040'/,NULL(1)/Z'F040
Cmw     $4040'/,KLAUF(1)/Z'4D404040'/,KLAZU(1)/Z'5D404040'/
      DATAIPUNKT(1)/Z'4040404B'/,ISTERN(1)/Z'4040405C'/,IBLANK(1)/Z'4040
     $4040'/,MINULL(1)/Z'4040F060'/,MINUS(1)/Z'40404060'/,NULL(1)/Z'4040
     $40F0'/,KLAUF(1)/Z'4040404D'/,KLAZU(1)/Z'4040405D'/
      CALL DB2255(IRFELD,IAFELD,LFELD)
      IF(LFELD .LE. 0) RETURN
      CALL DB2255(IRFELD+1,IAFELS,LFELDS)
      CALL DB2317(ICSD,IAFELD,IDUM,0,LFELD,NBRAS)
      DO 200 JDP = 1,LFELD
      IF(LCOMPS(IPUNKT,1,1,IDUM,JDP) .EQ. 0) GO TO 240
200   CONTINUE
      JDP = LFELD + 1
      CALL COPYCH(IPUNKT,1,1,IDUM,JDP)
      LFELD = LFELD + 1
240   IVS = NDP - JDP
      IF(IVS .LT. 0) GO TO 1000
      IF(IVS+LFELD .LE. LENF) GO TO 280
      IF(LFELDS .NE. 0) GO TO 1000
      LFELD = LENF - IVS
      IF(LFELD .LE. 0) GO TO 1000
280   CALL COPYCH(IDUM,1,LFELD,LINE,LINP+IVS)
      NEXT = LFELD + LINP + IVS
      NDPM1 = LINP + NDP - 2
      IF(LCOMPS(IBLANK,1,1,LINE,NDPM1) .EQ. 0)
     1  CALL COPYCH(NULL,1,1,LINE,NDPM1)
      IF(LCOMPS(MINUS,1,1,LINE,NDPM1) .EQ. 0)
     1  CALL COPYCH(MINULL,1,2,LINE,NDPM1-1)
      IF(LFELDS .GT. 0) GO TO 400
      IF(LCOMPS(IBLANK,1,1,LINE,LINP+NDP) .EQ. 0)
     1  CALL COPYCH(NULL,1,1,LINE,LINP+NDP)
      GO TO 9000
400   IF(LFELDS+2 .GT. LINP+LENF-NEXT) GO TO 500
      CALL COPYCH(KLAUF,1,1,LINE,NEXT)
      CALL DB2317(ICSD,IAFELS,LINE,NEXT,LFELDS,NBRAS)
      CALL COPYCH(KLAZU,1,1,LINE,NEXT+LFELDS+1)
      GO TO 9000
500   IHFLG = 1
      NEXT = LINP + LENF - LFELDS - 2
      CALL COPYCH(KLAUF,1,1,LINEH,NEXT)
      CALL DB2317(ICSD,IAFELS,LINEH,NEXT,LFELDS,NBRAS)
      CALL COPYCH(KLAZU,1,1,LINEH,NEXT+LFELDS+1)
      GO TO 9000
1000  JEND = LINP + LENF - 1
      DO 1100 J = LINP,JEND
1100  CALL COPYCH(ISTERN,1,1,LINE,J)
9000  RETURN
      END
C ----------------------------------------OWNUNC411----UPD861217--DB2215
      SUBROUTINE DB2215(ICD1,ICD2,LINE,LI)
      DIMENSION LINE(*)
      DIMENSION ITXT1(81), ITXT2(92)
      DIMENSION IDIR(76)
CHP8  DATA IDIR /
C    1'1','1',  5, 6,'2','1', 11,11,'2','2', 24,10,'2','3', 34, 9,
C    2'5','1', 43, 4,'5','2', 47, 7,'5','3', 54, 6,'5','4', 60, 7,
C    3'5','5', 67, 7,'5','6', 74, 5,'7','0', 79,10,'7','1', 89,12,
C    4'7','2',101,10,'7','3',111,11,'7','4',122,10,'7','5',132,11,
C    5'7','6',143,12,'7','7',155,09,'7','8',168, 6/
Cmw      DATAIDIR/Z'F1404040',Z'F1404040',5,6,Z'F2404040',Z'F1404040',11,11
Cmw     $,Z'F2404040',Z'F2404040',24,10,Z'F2404040',Z'F3404040',34,9,Z'F540
Cmw     $4040',Z'F1404040',43,4,Z'F5404040',Z'F2404040',47,7,Z'F5404040',Z'
Cmw     $F3404040',54,6,Z'F5404040',Z'F4404040',60,7,Z'F5404040',Z'F5404040
Cmw     $',67,7,Z'F5404040',Z'F6404040',74,5,Z'F7404040',Z'F0404040',79,10,
Cmw     $Z'F7404040',Z'F1404040',89,12,Z'F7404040',Z'F2404040',101,10,Z'F74
Cmw     $04040',Z'F3404040',111,11,Z'F7404040',Z'F4404040',122,10,Z'F740404
Cmw     $0',Z'F5404040',132,11,Z'F7404040',Z'F6404040',143,12,Z'F7404040',Z
Cmw     $'F7404040',155,09,Z'F7404040',Z'F8404040',168,6/
      DATAIDIR/Z'404040F1',Z'404040F1',5,6,Z'404040F2',Z'404040F1',11,11
     $,Z'404040F2',Z'404040F2',24,10,Z'404040F2',Z'404040F3',34,9,Z'4040
     $40F5',Z'404040F1',43,4,Z'404040F5',Z'404040F2',47,7,Z'404040F5',Z'
     $404040F3',54,6,Z'404040F5',Z'404040F4',60,7,Z'404040F5',Z'404040F5
     $',67,7,Z'404040F5',Z'404040F6',74,5,Z'404040F7',Z'404040F0',79,10,
     $Z'404040F7',Z'404040F1',89,12,Z'404040F7',Z'404040F2',101,10,Z'404
     $040F7',Z'404040F3',111,11,Z'404040F7',Z'404040F4',122,10,Z'404040F
     $7',Z'404040F5',132,11,Z'404040F7',Z'404040F6',143,12,Z'404040F7',Z
     $'404040F7',155,09,Z'404040F7',Z'404040F8',168,6/
      DATA MAXCOM/76/
CHP8  DATA ITXT1/
C    1'Inva','lid ','comm','ent ','Ques','tion','able',' str','uctu',
C    2're  ','Calc','ul. ','form','ula ','slig','htly',' dev','iate',
C    3's fr','om i','nput',' for','mula','Char','ge s','um s','ligh',
C    4'tly ','devi','ates',' fro','m ze','ro  ','Calc','. de','nsit',
C    5'y un','usua','l bu','t to','lera','ble ','No R',' val','ue g',
C    6'iven','At l','east',' one',' TF ','impl','ausi','ble ','At l',
C    7'east',' one',' TF ','miss','ing ','At l','east',' one',' SOF',
C    8' imp','laus','ible','Latt','ice ','para','mete','rs u','nusu',
C    9'al  ','Non-','stan','dard',' TF-','s   ','Pape','r re','port'/
Cmw      DATAITXT1/Z'C995A581',Z'93898440',Z'83969494',Z'8595A340',Z'D8A485
Cmw     $A2',Z'A3899695',Z'81829385',Z'40A2A399',Z'A483A3A4',Z'99854040',Z'
Cmw     $C3819383',Z'A4934B40',Z'86969994',Z'A4938140',Z'A2938987',Z'88A393
Cmw     $A8',Z'408485A5',Z'8981A385',Z'A2408699',Z'96944089',Z'9597A4A3',Z'
Cmw     $40869699',Z'94A49381',Z'C3888199',Z'878540A2',Z'A49440A2',Z'938987
Cmw     $88',Z'A393A840',Z'8485A589',Z'81A385A2',Z'40869996',Z'9440A985',Z'
Cmw     $99964040',Z'C3819383',Z'4B408485',Z'95A289A3',Z'A840A495',Z'A4A2A4
Cmw     $81',Z'934082A4',Z'A340A396',Z'93859981',Z'82938540',Z'D59640D9',Z'
Cmw     $40A58193',Z'A4854087',Z'89A58595',Z'C1A34093',Z'8581A2A3',Z'409695
Cmw     $85',Z'40E3C640',Z'89949793',Z'81A4A289',Z'82938540',Z'C1A34093',Z'
Cmw     $8581A2A3',Z'40969585',Z'40E3C640',Z'9489A2A2',Z'89958740',Z'C1A340
Cmw     $93',Z'8581A2A3',Z'40969585',Z'40E2D6C6',Z'40899497',Z'9381A4A2',Z'
Cmw     $89829385',Z'D381A3A3',Z'89838540',Z'97819981',Z'9485A385',Z'99A240
Cmw     $A4',Z'95A4A2A4',Z'81934040',Z'D5969560',Z'A2A38195',Z'84819984',Z'
Cmw     $40E3C660',Z'A2404040',Z'D7819785',Z'99409985',Z'979699A3'/
      DATAITXT1/Z'81A595C9',Z'40848993',Z'94949683',Z'40A39585',Z'A285A4
     $D8',Z'959689A3',Z'85938281',Z'99A3A240',Z'A4A383A4',Z'40408599',Z'
     $839381C3',Z'404B93A4',Z'94999686',Z'408193A4',Z'878993A2',Z'A893A3
     $88',Z'A5858440',Z'85A38189',Z'998640A2',Z'89409496',Z'A3A49795',Z'
     $99968640',Z'8193A494',Z'998188C3',Z'A2408587',Z'A24094A4',Z'888789
     $93',Z'40A893A3',Z'89A58584',Z'A285A381',Z'96998640',Z'85A94094',Z'
     $40409699',Z'839381C3',Z'8584404B',Z'A389A295',Z'95A440A8',Z'81A4A2
     $A4',Z'A4824093',Z'96A340A3',Z'81998593',Z'40859382',Z'D94096D5',Z'
     $9381A540',Z'874085A4',Z'9585A589',Z'9340A3C1',Z'A3A28185',Z'859596
     $40',Z'40C6E340',Z'93979489',Z'89A2A481',Z'40859382',Z'9340A3C1',Z'
     $A3A28185',Z'85959640',Z'40C6E340',Z'A2A28994',Z'40879589',Z'9340A3
     $C1',Z'A3A28185',Z'85959640',Z'C6D6E240',Z'97948940',Z'A2A48193',Z'
     $85938289',Z'A3A381D3',Z'40858389',Z'81998197',Z'85A38594',Z'A440A2
     $99',Z'A4A2A495',Z'40409381',Z'609596D5',Z'9581A3A2',Z'84998184',Z'
     $60C6E340',Z'404040A2',Z'859781D7',Z'85994099',Z'A3999697'/
CHP8  DATA
C    1ITXT2( 1),ITXT2( 2),ITXT2( 3),ITXT2( 4),ITXT2( 5),
C    2ITXT2( 6),ITXT2( 7),ITXT2( 8),ITXT2( 9),ITXT2(10),
C    3ITXT2(11),ITXT2(12),ITXT2(13),ITXT2(14),ITXT2(15),
C    4ITXT2(16),ITXT2(17),ITXT2(18),ITXT2(19),ITXT2(20),
C    5ITXT2(21),ITXT2(22),ITXT2(23),ITXT2(24),ITXT2(25),
C    6ITXT2(26),ITXT2(27),ITXT2(28),ITXT2(29),ITXT2(30),
C    7ITXT2(31),ITXT2(32),ITXT2(33),ITXT2(34),ITXT2(35),
C    8ITXT2(36)/
C    9's co','mple','x at','omic',' coo','rdin','ates','Coor','dina',
C    A'tes,',' spa','ce g','rp. ','or u','nit ','cell',' not',' det',
C    B'.   ','Coor','dina','tes ','dete','rmin','ed b','ut n','ot p',
C    C'ubli','shed','No c','oord','inat','es, ','only',' str','uctu'/
Cmw      DATAITXT2(1),ITXT2(2),ITXT2(3),ITXT2(4),ITXT2(5),ITXT2(6),ITXT2(7)
Cmw     $,ITXT2(8),ITXT2(9),ITXT2(10),ITXT2(11),ITXT2(12),ITXT2(13),ITXT2(1
Cmw     $4),ITXT2(15),ITXT2(16),ITXT2(17),ITXT2(18),ITXT2(19),ITXT2(20),ITX
Cmw     $T2(21),ITXT2(22),ITXT2(23),ITXT2(24),ITXT2(25),ITXT2(26),ITXT2(27)
Cmw     $,ITXT2(28),ITXT2(29),ITXT2(30),ITXT2(31),ITXT2(32),ITXT2(33),ITXT2
Cmw     $(34),ITXT2(35),ITXT2(36)/Z'A2408396',Z'94979385',Z'A74081A3',Z'969
Cmw     $48983',Z'40839696',Z'99848995',Z'81A385A2',Z'C3969699',Z'84899581'
Cmw     $,Z'A385A26B',Z'40A29781',Z'83854087',Z'99974B40',Z'969940A4',Z'958
Cmw     $9A340',Z'83859393',Z'409596A3',Z'408485A3',Z'4B404040',Z'C3969699'
Cmw     $,Z'84899581',Z'A385A240',Z'8485A385',Z'99948995',Z'85844082',Z'A4A
Cmw     $34095',Z'96A34097',Z'A4829389',Z'A2888584',Z'D5964083',Z'96969984'
Cmw     $,Z'899581A3',Z'85A26B40',Z'969593A8',Z'40A2A399',Z'A483A3A4'/
      DATAITXT2(1),ITXT2(2),ITXT2(3),ITXT2(4),ITXT2(5),ITXT2(6),ITXT2(7)
     $,ITXT2(8),ITXT2(9),ITXT2(10),ITXT2(11),ITXT2(12),ITXT2(13),ITXT2(1
     $4),ITXT2(15),ITXT2(16),ITXT2(17),ITXT2(18),ITXT2(19),ITXT2(20),ITX
     $T2(21),ITXT2(22),ITXT2(23),ITXT2(24),ITXT2(25),ITXT2(26),ITXT2(27)
     $,ITXT2(28),ITXT2(29),ITXT2(30),ITXT2(31),ITXT2(32),ITXT2(33),ITXT2
     $(34),ITXT2(35),ITXT2(36)/Z'968340A2',Z'85939794',Z'A38140A7',Z'838
     $99496',Z'96968340',Z'95898499',Z'A285A381',Z'999696C3',Z'81958984'
     $,Z'6BA285A3',Z'8197A240',Z'87408583',Z'404B9799',Z'A4409996',Z'40A
     $38995',Z'93938583',Z'A3969540',Z'A3858440',Z'4040404B',Z'999696C3'
     $,Z'81958984',Z'40A285A3',Z'85A38584',Z'95899499',Z'82408485',Z'954
     $0A3A4',Z'9740A396',Z'899382A4',Z'848588A2',Z'834096D5',Z'84999696'
     $,Z'A3819589',Z'406BA285',Z'A8939596',Z'99A3A240',Z'A4A383A4'/
CHP8  DATA
C    2          ITXT2(37),ITXT2(38),ITXT2(39),ITXT2(40),
C    3ITXT2(41),ITXT2(42),ITXT2(43),ITXT2(44),ITXT2(45),
C    4ITXT2(46),ITXT2(47),ITXT2(48),ITXT2(49),ITXT2(50),
C    5ITXT2(51),ITXT2(52),ITXT2(53),ITXT2(54),ITXT2(55),
C    6ITXT2(56),ITXT2(57),ITXT2(58),ITXT2(59),ITXT2(60),
C    7ITXT2(61),ITXT2(62),ITXT2(63),ITXT2(64),ITXT2(65),
C    8ITXT2(66),ITXT2(67),ITXT2(68),ITXT2(69),ITXT2(70),
C    9ITXT2(71),ITXT2(72)/
C    A're t','ype ','give','n   ','Coor','dina','tes ','from',' pap',
C    B'er o','bvio','usly',' wro','ng  ','Publ','ishe','d co','ordi',
C    C'nate','s ha','ve b','een ','corr','ecte','d   ','Shor','t di',
C    D'stan','ces,',' coo','rdin','ates',' pro','babl','y co','rrec'/
Cmw      DATAITXT2(37),ITXT2(38),ITXT2(39),ITXT2(40),ITXT2(41),ITXT2(42),IT
Cmw     $XT2(43),ITXT2(44),ITXT2(45),ITXT2(46),ITXT2(47),ITXT2(48),ITXT2(49
Cmw     $),ITXT2(50),ITXT2(51),ITXT2(52),ITXT2(53),ITXT2(54),ITXT2(55),ITXT
Cmw     $2(56),ITXT2(57),ITXT2(58),ITXT2(59),ITXT2(60),ITXT2(61),ITXT2(62),
Cmw     $ITXT2(63),ITXT2(64),ITXT2(65),ITXT2(66),ITXT2(67),ITXT2(68),ITXT2(
Cmw     $69),ITXT2(70),ITXT2(71),ITXT2(72)/Z'998540A3',Z'A8978540',Z'8789A5
Cmw     $85',Z'95404040',Z'C3969699',Z'84899581',Z'A385A240',Z'86999694',Z'
Cmw     $40978197',Z'85994096',Z'82A58996',Z'A4A293A8',Z'40A69996',Z'958740
Cmw     $40',Z'D7A48293',Z'89A28885',Z'84408396',Z'96998489',Z'9581A385',Z'
Cmw     $A2408881',Z'A5854082',Z'85859540',Z'83969999',Z'8583A385',Z'844040
Cmw     $40',Z'E2889699',Z'A3408489',Z'A2A38195',Z'8385A26B',Z'40839696',Z'
Cmw     $99848995',Z'81A385A2',Z'40979996',Z'82818293',Z'A8408396',Z'999985
Cmw     $83'/
      DATAITXT2(37),ITXT2(38),ITXT2(39),ITXT2(40),ITXT2(41),ITXT2(42),IT
     $XT2(43),ITXT2(44),ITXT2(45),ITXT2(46),ITXT2(47),ITXT2(48),ITXT2(49
     $),ITXT2(50),ITXT2(51),ITXT2(52),ITXT2(53),ITXT2(54),ITXT2(55),ITXT
     $2(56),ITXT2(57),ITXT2(58),ITXT2(59),ITXT2(60),ITXT2(61),ITXT2(62),
     $ITXT2(63),ITXT2(64),ITXT2(65),ITXT2(66),ITXT2(67),ITXT2(68),ITXT2(
     $69),ITXT2(70),ITXT2(71),ITXT2(72)/Z'A3408599',Z'408597A8',Z'85A589
     $87',Z'40404095',Z'999696C3',Z'81958984',Z'40A285A3',Z'94969986',Z'
     $97819740',Z'96409985',Z'9689A582',Z'A893A2A4',Z'9699A640',Z'404087
     $95',Z'9382A4D7',Z'8588A289',Z'96834084',Z'89849996',Z'85A38195',Z'
     $818840A2',Z'824085A5',Z'40958585',Z'99999683',Z'85A38385',Z'404040
     $84',Z'999688E2',Z'898440A3',Z'9581A3A2',Z'6BA28583',Z'96968340',Z'
     $95898499',Z'A285A381',Z'96999740',Z'93828182',Z'968340A8',Z'838599
     $99'/
CHP8  DATA                ITXT2(73),ITXT2(74),ITXT2(75),
C    4ITXT2(76),ITXT2(77),ITXT2(78),ITXT2(79),ITXT2(80),
C    5ITXT2(81),ITXT2(82),ITXT2(83),ITXT2(84),ITXT2(85),
C    6ITXT2(86),ITXT2(87),ITXT2(88),ITXT2(89),ITXT2(90),
C    6ITXT2(91),ITXT2(92)/
C    9't   ','Entr','y co','ntai','ns n','o at','omic',' par','amet',
C    A'ers ','****','****','****','****','Entr','y no','t ye','t co',
C    B'mple','te  '/
Cmw      DATAITXT2(73),ITXT2(74),ITXT2(75),ITXT2(76),ITXT2(77),ITXT2(78),IT
Cmw     $XT2(79),ITXT2(80),ITXT2(81),ITXT2(82),ITXT2(83),ITXT2(84),ITXT2(85
Cmw     $),ITXT2(86),ITXT2(87),ITXT2(88),ITXT2(89),ITXT2(90),ITXT2(91),ITXT
Cmw     $2(92)/Z'A3404040',Z'C595A399',Z'A8408396',Z'95A38189',Z'95A24095',
Cmw     $Z'964081A3',Z'96948983',Z'40978199',Z'819485A3',Z'8599A240',Z'5C5C
Cmw     $5C5C',Z'5C5C5C5C',Z'5C5C5C5C',Z'5C5C5C5C',Z'C595A399',Z'A8409596',
Cmw     $Z'A340A885',Z'A3408396',Z'94979385',Z'A3854040'/
      DATAITXT2(73),ITXT2(74),ITXT2(75),ITXT2(76),ITXT2(77),ITXT2(78),IT
     $XT2(79),ITXT2(80),ITXT2(81),ITXT2(82),ITXT2(83),ITXT2(84),ITXT2(85
     $),ITXT2(86),ITXT2(87),ITXT2(88),ITXT2(89),ITXT2(90),ITXT2(91),ITXT
     $2(92)/Z'404040A3',Z'99A395C5',Z'968340A8',Z'8981A395',Z'9540A295',
     $Z'A3814096',Z'83899496',Z'99819740',Z'A3859481',Z'40A29985',Z'5C5C
     $5C5C',Z'5C5C5C5C',Z'5C5C5C5C',Z'5C5C5C5C',Z'99A395C5',Z'969540A8',
     $Z'85A840A3',Z'968340A3',Z'85939794',Z'404085A3'/
      DATA INT5,INT6 /5,6/

      DO 200 J = 1,MAXCOM,4
      IF(ICD1 .NE. IDIR(J)) GO TO 200
      IF(ICD2 .EQ. IDIR(J+1)) GO TO 400
200   CONTINUE
      LINE(INT5) = ICD1
      LINE(INT6) = ICD2
      DO 300 J = 1,4
300   LINE(J) = ITXT1(J)
      LI = 6
      GO TO 9000
400   JAN = IDIR(J+2)
      LI = IDIR(J+3)
      JEND = IDIR(J+2) + LI - 1
      J1 = 1
      DO 500 J = JAN,JEND
      IF(J .GT. 81) GO TO 480
      LINE(J1) = ITXT1(J)
      GO TO 500
480   LINE(J1) = ITXT2(J-81)
500   J1 = J1 + 1
9000  RETURN
      END
C ----------------------------------------OWNUNC411----UPD850926--DB2216
      SUBROUTINE DB2216(MNAR,IADR,ICATEG,ISTRNG,
     1LSTRNG,IRC,NBRAS)
      DIMENSION MNAR(*),ISTRNG(*),NBRAS(*),IHELP(2),IRESP(4)
      COMMON /DC2201/ IFLAG(50)
CHP8  DATA ICK/'K'/, ICD/'D'/, ICN/'N'/, ICY/'Y'/, IFRAG/'H'/
Cmw      DATAICK/Z'D2404040'/,ICD/Z'C4404040'/,ICN/Z'D5404040'/,ICY/Z'E8404
Cmw     $040'/,IFRAG/Z'C8404040'/
      DATAICK/Z'404040D2'/,ICD/Z'404040C4'/,ICN/Z'404040D5'/,ICY/Z'40404
     $0E8'/,IFRAG/Z'404040C8'/
CHP8  DATA IHELP/'DB23','14H1'/, ICS/'S'/, IBLANK/'    '/
Cmw      DATAIHELP/Z'C4C2F2F3',Z'F1F4C8F1'/,ICS/Z'E2404040'/,IBLANK/Z'40404
Cmw     $040'/
      DATAIHELP/Z'F3F2C2C4',Z'F1C8F4F1'/,ICS/Z'404040E2'/,IBLANK/Z'40404
     $040'/
      LNGA = 0
      IHIT = 0
      ISCNT = 0
      ITYPAR = 0
      NPRINT = IFLAG(16)
      NINPT = IFLAG(25)
      IDBCB = IFLAG(40)
      IACTBS = MNAR(IDBCB+3)
      KFIRST = IDBCB + MNAR(IDBCB+1)
      LENDKB = MNAR(IDBCB)
      CALL DB2231(MNAR,128,IRK)
      IF(IRK .LE. 0) GO TO 3100
      ISTRBF = IRK
      CALL DB2229(MNAR,IADR,KOPIE,IRK)
      IF(IRK+1) 3200,3100,400
400   CALL DB2221(MNAR,KOPIE,1,IREL)
      IFUNK = 0
500   CALL DB2221(MNAR,KOPIE,IFUNK,IREL)
      IF(IREL .EQ. 0) GO TO 2000
      IF(MOD(ISCNT,IFLAG(17)) .NE. 0) GO TO 580
      IF(ISCNT .EQ. 0) GO TO 580
505   WRITE(NPRINT,510) ISCNT,IHIT
510   FORMAT(1X,I6,' Entries scanned.',I6,' hits. Continue(Y/N)?')
      CALL KEYBRD(NINPT,IANTW,1)
      IF(IANTW .EQ. ICY) GO TO 580
      IF(IANTW .EQ. ICN) GO TO 2000
      WRITE(NPRINT,2180)
      GO TO 505
580   ISCNT = ISCNT + 1
      IF(IACTBS .EQ. 0) GO TO 2000
      JP = KFIRST
      DO 582 JBAS = 1,IACTBS
      IZUG = MNAR(JP+66)
      IF(IREL .LE. (IZUG + MNAR(JP+130))) GO TO 585
      JP = JP + LENDKB
582   CONTINUE
      GO TO 2000
585   ICSX = MNAR(JP+64)
      CALL DB2250(IREL-IZUG,IZREC,MNAR(JP),NBRAS,IRK)
      IF(IRK .NE. 0) GO TO 940
595   LNGB = 3*IZREC + 60
      IF(LNGB .LE. LNGA) GO TO 700
      IF(LNGA .EQ. 0) GO TO 600
      CALL DB2232(MNAR,ITYPAR,IRK)
      IF(IRK .NE. 0) GO TO 3200
600   CALL DB2231(MNAR,LNGB,IRK)
      IF(IRK .LE. 0) GO TO 3100
      ITYPAR = IRK
      LNGA = LNGB
700   CALL DB2261(MNAR(ITYPAR),LNGB,NBRAS,IRK,ICATEG)
      CALL DB2257(MNAR(ITYPAR),ICATEG,IZAHL)
      IF(IZAHL .LE. 0) GO TO 940
      DO 900 J = 1,IZAHL
      CALL DB2252(ICATEG,J,MNAR(ITYPAR),NBRAS,IRK)
      IF(IRK .LE. 0) GO TO 900
      CALL DB2256(1,MNAR(ISTRBF),512,LEN,NBRAS)
      J2 = LEN - LSTRNG + 1
      IF(J2 .LE. 0) GO TO 900
      DO 840 J1 = 1,J2
      IF(LCOMPS(ISTRNG,1,LSTRNG,MNAR(ISTRBF),J1) .EQ. 0) GO TO 1000
840   CONTINUE
900   CONTINUE
940   IFUNK = 0
      GO TO 500
1000  IHIT = IHIT + 1
      IFUNK = -1
      GO TO 500
2000  CALL DB2221(MNAR,KOPIE,2,IREL)
      WRITE(NPRINT,2100) IHIT
2100  FORMAT(' String found in',I6,' entries.')
      IF(IHIT .EQ. 0) GO TO 3000
2120  CALL DB2315(40,NBRAS)
      CALL KEYBRD(NINPT,IANTW,1)
      IF(IANTW .EQ. ICK) GO TO 2200
      IF(IANTW .EQ. ICD) GO TO 2600
      IF(IANTW .EQ. ICN) GO TO 3000
      IF(IANTW .EQ. ICS) GO TO 2800
      IF(IANTW .EQ. IFRAG) GO TO 2700
      WRITE(NPRINT,2180)
2180  FORMAT(' Ill. response')
      GO TO 2120
2200  CALL DB2224(MNAR,IADR,KOPIE,IRK)
      IF(IRK+1) 3200,3100,3000
2600  CALL DB2232(MNAR,IADR,IRK)
      IF(IRK .NE. 0) GO TO 3200
      IADR = KOPIE
      GO TO 3060
2700  CALL DB2217(MNAR,IHELP,NBRAS,IRK)
      GO TO 2120
2800  CALL DB2315(38,NBRAS)
      CALL KEYBRD(NINPT,IRESP(2),2)
      IF(LCOMP(IRESP(2),IBLANK,1) .NE. 0) GO TO 2820
      CALL DB2315(42,NBRAS)
      GO TO 2800
2820  CALL DB2229(MNAR,IADR,KOPIE2,IRK)
      IF(IRK+1) 3200,3100,2840
2840  CALL DB2224(MNAR,KOPIE2,KOPIE,IRK)
      IF(IRK+1) 3200,3100,2860
2860  IRESP(1) = 2
      IRESP(4) = KOPIE2
      CALL DB2316(IRESP,J,MNAR,NBRAS,IRK)
      IRK = IRK + 3
      GO TO (3200,3100,2900,3200), IRK
2900  CALL DB2219(2216,2900)
      CALL DB2232(MNAR,KOPIE2,IRK)
      IF(IRK) 3200,3000,3200
3000  CALL DB2232(MNAR,KOPIE,IRK)
      IF(IRK .NE. 0) GO TO 3200
3060  IRC = 0
      CALL DB2232(MNAR,ISTRBF,IRK)
      IF(IRK) 3200,9000,3200
3100  IRC = 1
      GO TO 9900
3200  IRC = 2
      GO TO 9900
9000  IF(ITYPAR .EQ. 0) GO TO 9900
      CALL DB2232(MNAR,ITYPAR,IRK)
      IF(IRK .NE. 0) GO TO 3200
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2217
      SUBROUTINE DB2217(MNAR,IHELP,NBRAS,IRK)
      DIMENSION IHELP(*),NBRAS(*),MNAR(*),LINE(18)
       DIMENSION IBL(1)
      INTEGER DB2210
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2206/ ICSDCB(64),ITABCB(64),ICS2CB(64)
      COMMON /DC2209/ LINC,LINMA,LPRN,LNPUT,ISTIP
CHP8  DATA IBLANK/'    '/
      DATAIBLANK/Z'40404040'/
CHP8  DATA IBL(1)/'    '/
      DATAIBL(1)/Z'40404040'/
      IRK = 0
      NDSPL = IFLAG(16)
      ISOLL = 1
      LENIHL = 0
      DO 60 J = 1,8
      IF(LCOMPS(IHELP,J,1,IBL(1),1) .EQ. 0) GO TO 80
      LENIHL = J
60    CONTINUE
80    CALL DB2313(1,1,MNAR,NBRAS,IHD,LEN,IRC)
      IRC = IRC + 3
      GO TO (8800,8900,100,9000), IRC
100   IFOUND = 0
      IF(LENIHL .EQ. 0) LENIHL = 8
      DO 200 J = 1,LEN,10
      IF(LCOMPS(IHELP,1,LENIHL,MNAR(IHD),J) .NE. 0) GO TO 200
      MFOUND = J
      IFOUND = IFOUND + 1
      IF(LCOMPS(IHELP,1,8,MNAR(IHD),J) .EQ. 0) GO TO 300
200   CONTINUE
      IF(IFOUND - 1) 260,300,270
260   CALL DB2315(68,NBRAS)
      GO TO 9000
270   CALL DB2315(92,NBRAS)
      GO TO 9000
300   CALL CHRINT(MNAR(IHD),MFOUND+8,2,MEMNR)
320   J = DB2210(0)
      IF(IFLAG(37) .EQ. 0) CALL CLEAR
      CALL DB0121(0,LINE,0,72,LEN,ITABCB,NBRAS)
      ISTZ = 0
340   CALL DB0121(MEMNR+IFLAG(28),LINE,0,72,LEN,ITABCB,NBRAS)
      IF(LEN .LE. 0) GO TO 500
      ISTZ = ISTZ + 1
      IF(ISTZ - ISOLL) 340, 350, 320
350   ISTIP = 0
      IF(DB2210(1) .NE. 0) GO TO 500
      IF(ISTIP) 355,358,357
355   ISOLL = MAX0(ISOLL-LINMA+ISTIP+1, 1)
      GO TO 340
357   ISOLL = ISOLL  + ISTIP
      GO TO 340
358   ISOLL = ISOLL + 1
      JP = 18
      DO 360 J = 2,18
      IF(LINE(JP) .NE. IBLANK) GO TO 380
      JP = JP - 1
360   CONTINUE
380   CONTINUE
      CALL CICDC(LINE,1,4*JP)
      WRITE(NDSPL,400) (LINE(J),J=1,JP)
400   FORMAT(1X,17A4,A2)
      GO TO 340
500   CALL DB2219(2217,500)
      CALL DB2232(MNAR,IHD,NRC)
      IF(NRC) 8800,9000,8800
8800  IRK = -2
      GO TO 9000
8900  IRK = -1
9000  RETURN
      END
C ----------------------------------------OWNUNC411----UPD850926--DB2218
      SUBROUTINE DB2218(NDSPL)
C
C ---DISPLAY CPU-TIME, SESSION-TIME ETC. ON UNIT NDSPL
C
C     THIS ROUTINE IS CALLED FIRST ON CRYSTIN INITIALIZATION TIME,
C     THEN BY EVERY "TIME" COMMAND AND FINALLY BY THE "END" COMMAND.
C
      DATA INI/0/
C
      IF(INI .EQ. 0) GO TO 999
C
      WRITE(NDSPL,100)
100   FORMAT(' NO TIME ROUTINES IMPLEMENTED')
999   INI = 1
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850926--DB2219
      SUBROUTINE DB2219(IPROGR,LOC)
      COMMON /DC2201/ IFLAG(50)
      IF(IFLAG(5) .EQ. 0) GO TO 9000
      IVER = IFLAG(5)
      WRITE(IVER,200) IPROGR,LOC
200   FORMAT(' DB2219 - SPACE MANAGEMENT CALLED FROM DB',I4,' AT',I6)
9000  RETURN
      END
C ----------------------------------------OWNUNC411----UPD850829--DB2220
      SUBROUTINE DB2220 (MNAR,IADR1,IADR2,IRC)
      DIMENSION MNAR(*)
      COMMON /DC2227/ IBTMAX,IBITT(64)
      COMMON /DC2201/ IVRFL(50)
      IVER = IVRFL(5)
      IRC=0
      IFLAG2=0
   10 LEN1=MNAR(IADR1+1)
      LEN2=MNAR(IADR2+1)
      IF(LEN2 .EQ. 0) GO TO 999
      IF (MNAR(IADR1)) 50,20,330
   20 IF (MNAR(IADR2)) 50,30,190
   30 IF (LEN1 .GE. LEN2) GO TO 120
      LEN3=LEN2+4
      IF(IVER .NE. 0) CALL DB2219(2220,40)
      CALL DB2231 (MNAR,LEN3,IADR3)
      IF (IADR3) 40,50,60
   40 IRC=IADR3
      GO TO 999
   50 IRC=-2
      GO TO 999
   60 MNAR(IADR3)=0
      LEN3=LEN3-4
      MNAR(IADR3+1)=LEN3
      MNAR(IADR3+3)=0
      J1=IADR1+4
      J3=IADR3+4
      I=1
   70 MNAR(J3)=MNAR(J1)
      J1=J1+1
      J3=J3+1
      I=I+1
      IF (I-LEN1) 70,70,90
   80 J3=J3+1
      I=I+1
   90 MNAR(J3)=0
      IF (I-LEN3) 80,100,100
  100 IF(IVER .NE. 0) CALL DB2219(2220,100)
      CALL DB2232 (MNAR,IADR1,IRC)
      IF (IRC) 999,110,999
  110 IADR1=IADR3
      LEN1=LEN3
  120 J1=IADR1+4
      J2=IADR2+4
      DO 130 I=1,LEN2
      MNAR(J1)=LOR(MNAR(J1),MNAR(J2))
      J1=J1+1
      J2=J2+1
  130 CONTINUE
  140 MNAR(IADR1+2)=-1
      IF (IFLAG2) 150,999,150
  150 J2=J1-1
      LASTAD=IADR1+LEN1+3
      IF (LASTAD-J1) 999,999,160
  160 DO 180 I=J1,LASTAD
      IF (MNAR(I)) 170,180,170
  170 J2=I
  180 CONTINUE
      LEN1=J2-IADR1-3
      MNAR(IADR1+1)=LEN1
      IF(IVER .NE. 0) CALL DB2219(2220,180)
      CALL DB2234 (MNAR,LEN1+4,IADR1,IRC)
      IF(IRC) 50,999,999
  190 IF (MNAR(IADR2) .NE. 1) GO TO 50
      IFLAG=0
      ISAVE=1
      LASTZR=IADR1+LEN1+3
      J2=IADR2+4
  200 IADMAX=IADR1+LEN1+3
      DO 230 I=ISAVE,LEN2
      J=MNAR(J2)
      K=J/32
      J=J-32*K+1
      K=K+4+IADR1
      IF (K - IADMAX) 220,220,250
  210 LASTZR=LASTZR+1
      MNAR(LASTZR)=0
  220 IF (LASTZR .LT. K) GO TO 210
      MNAR(K)=LOR(MNAR(K),IBITT(J))
      J2=J2+1
  230 CONTINUE
      IF (IFLAG2) 240,140,240
  240 MNAR(IADR1+1)=LASTZR-IADR1-3
      IF(IVER .NE. 0) CALL DB2219(2220,240)
      CALL DB2234 (MNAR,MNAR(IADR1+1)+4,IADR1,IRC)
      MNAR(IADR1+2)=-1
      GO TO 999
  250 ISAVE=I
      IF (IFLAG) 320,260,320
  260 IFLAG=1
      IF(IVER .NE. 0) CALL DB2219(2220,260)
      CALL DB2235 (MNAR,LEN3,IADR3)
      IF (IADR3) 270,50,280
  270 IRC=IADR3
      GO TO 999
  280 LEN3=LEN3-4
      IF (LEN3 .LE. LEN1) GO TO 320
  290 J1=IADR1
      J3=IADR3
      J4=IADR1+LEN1+3
      DO 300 I=J1,J4
      MNAR(J3)=MNAR(I)
      J3=J3+1
  300 CONTINUE
      LASTZR=J3-1
      IFLAG2=1
      MNAR(IADR3+1)=LEN3
      IF(IVER .NE. 0) CALL DB2219(2220,310)
      CALL DB2232 (MNAR,IADR1,IRC)
      IF (IRC) 999,310,50
  310 IADR1=IADR3
      LEN1=LEN3
      GO TO 200
  320 IRC=-1
      GO TO 999
  330 IF (MNAR(IADR1) .NE. 1) GO TO 50
      IF (MNAR(IADR2)) 50,340,370
  340 CALL DB2225 (MNAR,IADR3,IADR1,0,IRC)
      IF (IRC) 999,350,999
  350 IFLAG2=1
      IF(IVER .NE. 0) CALL DB2219(2220,360)
      CALL DB2232 (MNAR,IADR1,IRC)
      IF (IRC) 50,360,50
  360 IADR1=IADR3
      GO TO 10
  370 IF (MNAR(IADR2) .NE. 1) GO TO 50
      LEN3=LEN1+LEN2+4
      IF(IVER .NE. 0) CALL DB2219(2220,380)
      CALL DB2231 (MNAR,LEN3,IADR3)
      IF (IADR3) 40,50,380
  380 MNAR(IADR3)=1
      LEN3=LEN3-4
      MNAR(IADR3+1)=LEN3
      MNAR(IADR3+2)=1
      MNAR(IADR3+3)=0
      J1=IADR1+4
      J2=IADR2+4
      J3=IADR3+4
      IF(LEN1 .EQ. 0) GO TO 400
      DO 390 I=1,LEN1
      MNAR(J3)=MNAR(J1)
      J1=J1+1
      J3=J3+1
  390 CONTINUE
  400 IF (LEN2 .EQ. 0) GO TO 420
      DO 410 I=1,LEN2
      MNAR(J3)=MNAR(J2)
      J2=J2+1
      J3=J3+1
  410 CONTINUE
  420 IF(IVER .NE. 0) CALL DB2219(2220,420)
      CALL DB2232 (MNAR,IADR1,IRC)
      IF (IRC) 999,430,999
  430 IADR1=IADR3
  999 CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850926--DB2221
      SUBROUTINE DB2221 (MNAR,IADR,INI,IREL)
      DIMENSION MNAR(*)
      COMMON /DC2227/ IBTMAX,IBITT(64)
      DATA ISTTUS/-1/
      IF (INI) 30,30,10
   10 IF (INI-2) 20,140,990
   20 ISTTUS=MNAR(IADR)
      IWORT=IADR+3
      IWRTCP=IWORT
      IBIT=0
      LASTAD=IADR+MNAR(IADR+1)+3
      GO TO 999
   30 IF (ISTTUS) 990,40,110
   40 IF (INI) 50,60,60
   50 MNAR(IWORT)=LAND(MNAR(IWORT),IBITT(IBIT+32))
      MNAR(IADR+2)=-1
   60 IF (IBIT) 70,70,80
   70 IF (IWORT .GE. LASTAD) GO TO 980
      IWORT=IWORT+1
      IF (MNAR(IWORT)) 80,70,80
   80 IF (IBIT .LT. 32) GO TO 90
      IBIT=0
      GO TO 70
   90 IBIT=IBIT+1
      IF (LAND(MNAR(IWORT),IBITT(IBIT))) 100,80,100
  100 IREL=(IWORT-IADR-4)*32+IBIT-1
      GO TO 999
  110 IF (INI) 130,115,115
  115 IF (IWORT-IWRTCP) 130,130,120
  120 IWRTCP=IWRTCP+1
      MNAR(IWRTCP)=MNAR(IWORT)
  130 IF (IWORT .GE. LASTAD) GO TO 175
      IWORT=IWORT+1
      IREL=MNAR(IWORT)
      GO TO 999
  140 IF (ISTTUS) 990,980,150
  150 IF (IWRTCP+1-IWORT) 170,980,980
  160 IWRTCP=IWRTCP+1
      MNAR(IWRTCP)=MNAR(IWORT)
      IWORT=IWORT+1
  170 IF (IWORT .LE. LASTAD) GO TO 160
  175 LEN=IWRTCP-IADR-3
      IF (MNAR(IADR+1)-LEN) 180,980,180
  180 MNAR(IADR+1)=LEN
      CALL DB2234 (MNAR,LEN+4,IADR,IRC)
  980 ISTTUS=-1
  990 IREL=0
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD850926--DB2222
      SUBROUTINE DB2222 (MNAR,IADR,ICOUNT)
      DIMENSION MNAR(*)
      COMMON /DC2227/ IBTMAX,IBITT(64)
   5  ITYP=MNAR(IADR)
      IF (ITYP) 30,10,110
  10  ICOUNT=MNAR(IADR+2)
      IF (ICOUNT) 20,999,999
  20  LEN=MNAR(IADR+1)
      IF (LEN) 30,40,50
  30  ICOUNT=-2
      GO TO 999
  40  ICOUNT=0
      GO TO 999
  50  L=IADR+4
      ICOUNT=0
      DO 100 I=1,LEN
      ITMP1=MNAR(L)
      IF (ITMP1) 60,90,60
  60  DO 80 J=1,32
      IF (LAND(ITMP1,IBITT(J))) 70,80,70
  70  ICOUNT=ICOUNT+1
  80  CONTINUE
  90  L=L+1
 100  CONTINUE
      MNAR(IADR+2)=ICOUNT
      GO TO 999
 110  IF (ITYP-1) 30,120,30
 120  ICOUNT=MNAR(IADR+1)
      IF (MNAR(IADR+2)) 130,999,130
 130  CALL DB2225 (MNAR,IADRB,IADR,1,IRC)
      IF (IRC) 30,140,30
 140  CALL DB2232 (MNAR,IADR,IRC)
      IF (IRC) 30,150,30
 150  IADR=IADRB
      GO TO 5
 999  RETURN
      END
C ----------------------------------------OWNUNC411----UPD850926--DB2223
      SUBROUTINE DB2223 (MNAR,IADR1,IADR2,IRC)
      DIMENSION MNAR(*)
      COMMON /DC2227/ IBTMAX,IBITT(64)
      COMMON /DC2201/ IFLAG(50)
      IRC=0
      IVER = IFLAG(5)
      LEN1=MNAR(IADR1+1)
      LEN2=MNAR(IADR2+1)
      IF (MNAR(IADR1)) 10,20,170
  10  IRC=-2
      GO TO 999
  20  IF (MNAR(IADR2)) 10,30,90
  30  LENMIN=LEN1
      IF (LEN1 .GT. LEN2) LENMIN=LEN2
      IF (LENMIN) 10,40,70
  40  IF (LEN1) 10,999,50
  50  MNAR(IADR1+1)=0
      MNAR(IADR1+2)=0
  60  IF(IVER .NE. 0) CALL DB2219(2223,60)
      CALL DB2234 (MNAR,MNAR(IADR1+1)+4,IADR1,IRC)
      IF (IRC) 999,999,10
  70  J1=IADR1+4
      J2=IADR1+LENMIN+3
      J3=IADR2+4
      DO 80 I=J1,J2
      MNAR(I)=LAND(MNAR(I),MNAR(J3))
      J3=J3+1
  80  CONTINUE
      MNAR(IADR1+2)=-1
      IF (LEN1 .LE. LEN2) GO TO 999
      MNAR(IADR1+1)=LEN2
      GO TO 60
  90  IF (MNAR(IADR2) .NE. 1) GO TO 10
      IF(IVER .NE. 0) CALL DB2219(2223,90)
      CALL DB2231 (MNAR,LEN1+4,IADR3)
      IF (IADR3) 100,10,110
 100  IRC=IADR3
      GO TO 999
 110  J1=IADR1
      J2=IADR1+3
      J3=IADR3
      DO 120 I=J1,J2
      MNAR(J3)=MNAR(I)
 120  J3=J3+1
      LASTZR=J3-1
      J2=J2+LEN1
      L1=IADR2+4
      L2=IADR2+LEN2+3
      DO 140 I=L1,L2
      K=MNAR(I)/32
      J=MNAR(I)-K*32+1
      K1=K+IADR1+4
      K=K+IADR3+4
      IF (K1-J2) 130,130,140
 128  LASTZR=LASTZR+1
      MNAR(LASTZR)=0
 130  IF (K .GT. LASTZR) GO TO 128
      J1=LAND(MNAR(K1),IBITT(J))
      MNAR(K)=LOR(MNAR(K),J1)
 140  CONTINUE
      LEN3=LASTZR-IADR3-3
      MNAR(IADR3+1)=LEN3
      MNAR(IADR3+2)=-1
      IF (LEN3 .GE. LEN1) GO TO 150
      IF(IVER .NE. 0) CALL DB2219(2223,140)
      CALL DB2234 (MNAR,LEN3+4,IADR3,IRC)
      IF (IRC) 999,150,10
 150  IF(IVER .NE. 0) CALL DB2219(2223,150)
      CALL DB2232 (MNAR,IADR1,IRC)
      IF (IRC) 999,160,10
 160  IADR1=IADR3
      GO TO 999
 170  IF (MNAR(IADR1) .NE. 1) GO TO 10
      IF (MNAR(IADR2)) 10,180,220
 180  IADRT=IADR2
      LENT=LEN2
 185  L1=IADR1+4
      L2=IADR1+LEN1+3
      L3=IADR1+3
      IADMAX=IADRT+LENT+3
      DO 200 I=L1,L2
      L4=MNAR(I)
      K=L4/32
      J=L4-K*32+1
      K=K+IADRT+4
      IF (K .GT. IADMAX) GO TO 200
      IF (LAND(MNAR(K),IBITT(J))) 190,200,190
 190  L3=L3+1
      MNAR(L3)=MNAR(I)
 200  CONTINUE
      IF (L3 .GE. L2) GO TO 210
      LEN1=L3-IADR1-3
      MNAR(IADR1+1)=LEN1
      IF(IVER .NE. 0) CALL DB2219(2223,200)
      CALL DB2234 (MNAR,LEN1+4,IADR1,IRC)
      IF (IRC) 10,210,10
 210  IF (IADRT .EQ. IADR2) GO TO 999
      IF(IVER .NE. 0) CALL DB2219(2223,210)
      CALL DB2232 (MNAR,IADRT,IRC)
      IF (IRC) 10,999,10
 220  IF (MNAR(IADR2) .NE. 1) GO TO 10
      CALL DB2225 (MNAR,IADRT,IADR2,1,IRC)
      IF (IRC) 999,230,10
 230  LENT=MNAR(IADRT+1)
      GO TO 185
 999  RETURN
      END
C ----------------------------------------OWNUNC411----UPD850926--DB2224
      SUBROUTINE DB2224 (MNAR,IADR1,IADR2,IRC)
      DIMENSION MNAR(*)
      COMMON /DC2227/ IBTMAX,IBITT(64)
      IRC=0
      LEN1=MNAR(IADR1+1)
      LEN2=MNAR(IADR2+1)
      IF (MNAR(IADR1)) 10,20,110
   10 IRC=-2
      GO TO 999
   20 IF (MNAR(IADR2)) 10,30,80
   30 LENMIN=LEN1
      IF (LEN1 .GT. LEN2) LENMIN=LEN2
      IF (LENMIN) 10,999,40
   40 J1=IADR1+4
      J2=IADR1+LENMIN+3
      J3=IADR2+4
      DO 50 I=J1,J2
      JCOMPL=LCOMPL(MNAR(J3))
      MNAR(I)=LAND(MNAR(I),JCOMPL)
      J3=J3+1
   50 CONTINUE
      MNAR(IADR1+2)=-1
      J2=IADR1+LEN1+3
      J3=J1-1
      DO 70 I=J1,J2
      IF (MNAR(I)) 60,70,60
   60 J3=I
   70 CONTINUE
      IF (J3 .GE. J2) GO TO 999
      J2=J2-IADR1-3
      MNAR(IADR1+1)=J2
      CALL DB2234 (MNAR,J2+4,IADR1,IRC)
      IF (IRC) 999,999,10
   80 IF (MNAR(IADR2) .NE. 1) GO TO 10
      L1=IADR2+4
      L2=IADR2+LEN2+3
      J2=IADR1+LEN1+3
      DO 100 I=L1,L2
      K=MNAR(I)/32
      J=MNAR(I)-K*32+33
      K=K+IADR1+4
      IF (K-J2) 90,90,100
   90 MNAR(K)=LAND(MNAR(K),IBITT(J))
  100 CONTINUE
      MNAR(IADR1+2)=-1
      GO TO 999
  110 IF (MNAR(IADR1) .NE. 1) GO TO 10
      IF (MNAR(IADR2)) 10,120,170
  120 IADRT=IADR2
      LENT=LEN2
  130 L1=IADR1+4
      L2=IADR1+LEN1+3
      L3=IADR1+3
      IADMAX=IADRT+LENT+3
      DO 150 I=L1,L2
      L4=MNAR(I)
      K=L4/32
      J=L4-K*32+1
      K=K+IADRT+4
      IF (K .GT. IADMAX) GO TO 140
      IF (LAND(MNAR(K),IBITT(J))) 150,140,150
  140 L3=L3+1
      MNAR(L3)=MNAR(I)
  150 CONTINUE
      IF (L3 .GE. L2) GO TO 160
      LEN1=L3-IADR1-3
      MNAR(IADR1+1)=LEN1
      CALL DB2234 (MNAR,LEN1+4,IADR1,IRC)
      IF (IRC) 10,160,10
  160 IF (IADRT .EQ. IADR2) GO TO 999
      CALL DB2232 (MNAR,IADRT,IRC)
      IF (IRC) 10,999,10
  170 IF (MNAR(IADR2) .NE. 1) GO TO 10
      CALL DB2225 (MNAR,IADRT,IADR2,1,IRC)
      IF (IRC) 999,180,10
  180 LENT=MNAR(IADRT+1)
      GO TO 130
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD850830--DB2225
      SUBROUTINE DB2225 (MNAR,IADRB,IADRL,IRLSE,IRC)
      DIMENSION MNAR(*)
      COMMON /DC2227/ IBTMAX,IBITT(64)
   10 CALL DB2235 (MNAR,LENMAX,IRC)
      IF (IRC) 999,20,30
   20 IRC=-2
      GO TO 999
   30 IF (LENMAX-5) 40,50,50
   40 IRC=-1
      GO TO 999
   50 IADRB=IRC
      IRC=0
      MNAR(IADRB)=0
      I=-1
      MNAR(IADRB+3)=0
      LENMAX=IADRB+LENMAX-1
      LASTZR=IADRB+3
      LEN=MNAR(IADRL+1)
      IF (MNAR(IADRL+2)) 70,60,70
   60 I=LEN
   70 MNAR(IADRB+2)=I
      IF (LEN) 80,80,90
   80 MNAR(IADRB+1)=0
      GO TO 140
   90 L=IADRL+4
      DO 130 I=1,LEN
      J=MNAR(L)
      K=J/32
      J=J-K*32+1
      K=IADRB+K+4
      IF (K-LENMAX) 110,110,40
  100 LASTZR=LASTZR+1
      MNAR(LASTZR)=0
  110 IF (LASTZR-K) 100,120,120
  120 MNAR(K)=LOR(MNAR(K),IBITT(J))
      L=L+1
  130 CONTINUE
  140 IF (IRLSE) 170,160,170
  150 LASTZR=LASTZR+1
      MNAR(LASTZR)=0
  160 IF (LASTZR-LENMAX) 150,170,170
  170 LENB=LASTZR-IADRB-3
      MNAR(IADRB+1)=LENB
      IF (IRLSE) 180,999,180
  180 CALL DB2234 (MNAR,LENB+4,IADRB,IRC)
 999  CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2227
      SUBROUTINE DB2227
      COMMON /DC2227/IBTMAX,IBITT(64)
       DATA ITMP1,ITMP2,ITMP3
     1    /Z'80000000',Z'7FFFFFFF',Z'FFFFFFFE'/
Cmw       bei Bitmap darf wohl nicht verdreht werden !?
Cmw       DATA ITMP1,ITMP2,ITMP3
Cmw     1    /Z'00000080',Z'FFFFFF7F',Z'FEFFFFFF'/

      IBTMAX=10
      IBC=ITMP3
      IBT=1
      I=1
   10 CALL INTCHR (IBT,4,IBITT(I),1)
      CALL INTCHR (IBC,4,IBITT(I+32),1)
      I=I+1
      IF (I-32) 20,30,999
   20 IBC=IBC-IBT
      IBT=IBT*2
      GO TO 10
   30 IBC=ITMP2
      IBT=ITMP1
      GO TO 10
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2228
      SUBROUTINE DB2228 (MNAR,IADR,IRVON,IRBIS,IRC)
      DIMENSION MNAR(*)
      COMMON /DC2227/ IBTMAX,IBITT(64)
       DATA IFULL/Z'FFFFFFFF'/
      IRC=0
      IF (IRVON .GT. IRBIS) GO TO 10
      LENB=IRBIS/32+5
      LENL=IRBIS-IRVON+5
      IF (LENL .LE. LENB) GO TO 140
      CALL DB2219 (2228,10)
      CALL DB2231 (MNAR,LENB,IADR)
      IF (IADR) 20,10,30
   10 IADR=-2
   20 IRC=IADR
      GO TO 999
   30 LENB=LENB-4
      MNAR(IADR)=0
      MNAR(IADR+1)=LENB
      MNAR(IADR+2)=LENL-4
      MNAR(IADR+3)=0
      K1=IRVON/32
      J1=IRVON-32*K1+1
      K1=K1+IADR+4
      K2=IRBIS/32
      J2=IRBIS-32*K2+1
      K2=K2+IADR+4
      K=IADR+3
      GO TO 50
   40 K=K+1
      MNAR(K)=0
   50 IF (K-K2) 40,60,60
   60 IS=J1
      IF (K1-K2) 70,120,10
   70 DO 80 I=J1,32
   80 MNAR(K1)=MNAR(K1)+IBITT(I)
      GO TO 100
   90 MNAR(K1)=IFULL
  100 K1=K1+1
      IF (K1-K2) 90,110,110
  110 IS=1
  120 DO 130 I=IS,J2
  130 MNAR(K1)=MNAR(K1)+IBITT(I)
      GO TO 999
  140 CALL DB2219 (2228,140)
      CALL DB2231 (MNAR,LENL,IADR)
      IF (IADR) 20,10,150
  150 LENL=LENL-4
      MNAR(IADR)=1
      MNAR(IADR+1)=LENL
      MNAR(IADR+2)=0
      MNAR(IADR+3)=0
      K=IADR+4
      J=IRVON
      DO 160 I=1,LENL
      MNAR(K)=J
      K=K+1
      J=J+1
  160 CONTINUE
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2229
      SUBROUTINE DB2229 (MNAR,IADR1,IADR2,IRC)
      DIMENSION MNAR(*)
      COMMON /DC2201/ IFLAG(50)
      IRC=0
      LEN=MNAR(IADR1+1)+4
      IF(IFLAG(5) .NE. 0) CALL DB2219(2229,10)
      CALL DB2231 (MNAR,LEN,IADR2)
      IF (IADR2) 20,10,30
   10 IRC=-2
      GO TO 999
   20 IRC=IADR2
      GO TO 999
   30 J1=IADR2
      K1=IADR1
      DO 40 I=1,LEN
      MNAR(J1)=MNAR(K1)
      J1=J1+1
      K1=K1+1
   40 CONTINUE
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD851015--DB2230
      SUBROUTINE DB2230(NAR,NARDIM)
      DIMENSION NAR(NARDIM)
      NAR(1) = 333 333 333
      NAR(2) = NARDIM
      NAR(3) = 0
      NAR(4) = NARDIM - 5
      NAR(NARDIM) = 777 777 777
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD851015--DB2231
      SUBROUTINE DB2231(NAR,LEN,JP)
      DIMENSION NAR(*)
      COMMON /DC2201/ IFLAG(50)
      NDSPL = IFLAG(16)
      IF(IFLAG(7) .NE. 0) CALL DB2233(NAR,NDSPL)
      LENP4 = LEN+4
      NBP = 1
      IFOUND = 0
      IF(NAR(1) .EQ. 333 333 333) GO TO 110
      GO TO 701
100   IF(NAR(NBP) .NE. 555 555 555) GO TO 400
110   IF(NAR(NBP+3) - LENP4) 120,340,200
120   NBP = NAR(NBP+1)
      GO TO 100
200   IF(IFOUND .EQ. 0) GO TO 240
      IF(NAR(NBP+3) .GE. LFREI) GO TO 300
240   LFREI = NAR(NBP+3)
      IFOUND = NBP
300   NBP = NAR(NBP+1)
      GO TO 100
340   IFOUND = NBP
      GO TO 500
400   IF(NAR(NBP) .NE. 777 777 777) GO TO 702
      IF(IFOUND .EQ. 0) GO TO 600
500   NEXT = NAR(IFOUND+1)
      NBPNEW = NEXT - NAR(IFOUND+3)
      JP = NBPNEW + 4
      NAR(NBPNEW) = 555 555 555
      NAR(NBPNEW+1) = NEXT
      NAR(NBPNEW+2) = IFOUND
      NAR(NBPNEW+3) = NAR(IFOUND+3) - LENP4
      NAR(IFOUND+1) = NBPNEW
      NAR(IFOUND+3) = 0
      IF(NAR(NEXT) .EQ. 777 777 777) GO TO 9000
      IF(NAR(NEXT) .NE. 555 555 555) GO TO 703
      NAR(NEXT+2) = NBPNEW
      GO TO 9000
600   JP = -1
      WRITE(NDSPL,620) LEN
620   FORMAT(' DB2231 - Array request LEN=',I5,'. Not found.')
      GO TO 9900
701   CONTINUE
702   CONTINUE
703   CONTINUE
704   JP = -2
      WRITE(NDSPL,800)
800   FORMAT(' DB2231 - TEST MARK DESTROYED')
      GO TO 9900
9000  IF(IFLAG(5) .NE. 0) WRITE(NDSPL,9100) JP,LEN
9100  FORMAT(' DB2231 - ARRAY CREATED. ORG=',I6,'  LEN=',I5)
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD851015--DB2232
      SUBROUTINE DB2232(NAR,JP,NRC)
      DIMENSION NAR(*)
      COMMON /DC2201/ IFLAG(50)
      NDSPL = IFLAG(16)
      IF(IFLAG(7) .NE. 0) CALL DB2233(NAR,NDSPL)
      NRC = 0
      NBPFR = JP - 4
      IF(NAR(NBPFR) .NE. 555 555 555) GO TO 500
      NAR(NBPFR) = 123456789
100   NBPVOR = NAR(NBPFR+2)
      IF (NAR(NBPVOR) .EQ. 555 555 555) GO TO 200
      IF (NAR(NBPVOR) .NE. 333 333 333) GO TO 500
200   NBPFLG = NAR(NBPFR+1)
      IF(NAR(NBPFLG) .EQ. 555 555 555) GO TO 300
      IF(NAR(NBPFLG) .NE. 777 777 777) GO TO 500
300   LENGS = NBPFLG - NBPFR
      NAR(NBPVOR+1) = NBPFLG
      NAR(NBPVOR+3) = NAR(NBPVOR+3) + LENGS
      IF(NAR(NBPFLG) .NE. 777 777 777) NAR(NBPFLG+2) = NBPVOR
      GO TO 9000
500   NRC = 1
      GO TO 9900
9000  IF(IFLAG(5) .EQ. 0) GO TO 9900
      WRITE(NDSPL,9100) JP
9100  FORMAT(' DB2232 - ARRAY SCRATCHED. ORG=',I6)
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD851015--DB2233
      SUBROUTINE DB2233(NAR,NPRINT)
      DIMENSION NAR(*)
      NBP = 1
      WRITE(NPRINT,60)
60    FORMAT('   ADDR.',14X,'NEXT   PREC.    USED    FREE')
100   IRES = NAR(NBP+1) - NBP - NAR(NBP+3) - 4
      WRITE(NPRINT,200) NBP,NAR(NBP),NAR(NBP+1),NAR(NBP+2),IRES,
     1NAR(NBP+3)
200   FORMAT(1X,I7,I10,4I8)
      NBP = NAR(NBP+1)
      IF(NAR(NBP) .EQ. 555 555 555) GO TO 100
      IF(NAR(NBP) .NE. 777 777 777) GO TO 280
      WRITE(NPRINT,200) NBP,NAR(NBP)
      RETURN
280   WRITE(NPRINT,300)
300   FORMAT(' *****     ERROR IN SPACE MANAGEMENT     *****')
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD851015--DB2235
      SUBROUTINE DB2234(NAR,LEN,JQ,IRETCD)
      DIMENSION NAR(*)
      COMMON /DC2201/ IFLAG(50)
      IVER = IFLAG(5)
      IRETCD = 0
      IF (LEN .LE. 0) GO TO 1000
      JP = JQ - 4
      IF(JP .LT. 1) GO TO 1000
      IF(NAR(JP) .EQ. 555 555 555) GO TO 200
      IF(NAR(JP) .NE. 333 333 333) GO TO 1000
200   IDELT = NAR(JP+1) - JP - NAR(JP+3) - 4 - LEN
      IF(IDELT .LT. 0) GO TO 1000
      NAR(JP+3) = NAR(JP+3) + IDELT
      GO TO 9000
1000  IRETCD = -1
      IF(IVER .NE.0) WRITE(IVER,1100) JQ,LEN
1100  FORMAT(' DB2234 - ERROR. CALLED WITH ORG=',I6,'  NEWLEN=',I6)
      GO TO 9900
9000  IF(IVER .NE. 0) WRITE(IVER,9100) JQ,LEN
9100  FORMAT(' DB2234 - ARRAY RELEASED. ORG=',I6,'  NEWLEN=',I6)
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2235
      SUBROUTINE DB2235(NAR,LEN,JP)
      DIMENSION NAR(*)
      COMMON /DC2201/ IFLAG(50)
      LMAX = -1
      NBP = 1
      IF(NAR(1) - 333 333 333) 700,300,700
200   IF(NAR(NBP) .NE. 555 555 555) GO TO 500
300   IF(NAR(NBP+3) .GT. LMAX) GO TO 400
      GO TO 440
400   IFOUND = NBP
      LMAX = NAR(NBP + 3)
440   NBP = NAR(NBP + 1)
      GO TO 200
500   IF(NAR(NBP) .NE. 777 777 777) GO TO 700
      IF(LMAX .LT. 5) GO TO 600
      NEXT = NAR(IFOUND+1)
      NBPNEW = NEXT - NAR(IFOUND+3)
      JP = NBPNEW + 4
      LEN = LMAX - 4
      NAR(NBPNEW) = 555 555 555
      NAR(NBPNEW+1) = NEXT
      NAR(NBPNEW+2) = IFOUND
      NAR(NBPNEW+3) = 0
      NAR(IFOUND+1) = NBPNEW
      NAR(IFOUND+3) = 0
      IF(NAR(NEXT) .EQ. 777 777 777) GO TO 9000
      IF(NAR(NEXT) .NE. 555 555 555) GO TO 700
      NAR(NEXT+2) = NBPNEW
      GO TO 9000
600   JP = -1
      GO TO 9900
700   JP = -2
      GO TO 9900
9000  IF(IFLAG(5) .EQ. 0) GO TO 9900
      IVER = IFLAG(5)
      WRITE(IVER,9100) JP,LEN
9100  FORMAT(' DB2235 - MAX. ARRAY CREATED. ORG=',I6,'  LEN=',I6)
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD861217--DB2250
      SUBROUTINE DB2250(IREL,IZR,ICSDCB,NBRAS,IRETCD)
      COMMON /DC2249/ ICSDC,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,ISFRST,NFLDS,IFLDAD(20),IFLDLN(20)
      DIMENSION NBRAS(*),ICSDCB(64)
       INTEGER KLAX(1)
CHP8  DATA KLA/'@E'/
Cmw      DATAKLA/Z'7CC54040'/
      DATAKLA/Z'4040C57C'/
CHP8  DATA KLAX(1)/'@E'/
Cmw      DATAKLAX(1)/Z'7CC54040'/
      DATAKLAX(1)/Z'4040C57C'/
      ICSDC = ICSDCB(33)
      IRETCD = 0
      CALL DB0128(IREL,IDIR,IENTAD,MEMLEN,ICSDCB,NBRAS)
      IF(MEMLEN .LT. 80) GO TO 9000
      CALL DB2317(ICSDC,IENTAD,ICARD,0,80,NBRAS)
      IF(LCOMPS(ICARD,1,2,KLAX(1),1) .NE. 0) GO TO 9020
      CALL DB2213(ICARD,9,3,IZREC)
      IF(IZREC .LE. 0) GO TO 9020
      IZR = IZREC
      RETURN
9000  IF(MEMLEN .GE. 0) GO TO 9020
      IF(MEMLEN .EQ. -1) GO TO 9040
      IF(MEMLEN .EQ. -2) GO TO 9060
      IRETCD = 4
      GO TO 9100
9020  IRETCD = 1
      GO TO 9100
9040  IRETCD = 2
      GO TO 9100
9060  IRETCD = 3
9100  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860922--DB2251
      SUBROUTINE DB2251(IAR,IARDIM,NBRAS,IRETCD)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,ISFRST,NFLDS,IFLDAD(20),IFLDLN(20)
       COMMON /DC2201/ IFLAG(50)
      DIMENSION IAR(*),NBRAS(*)
      IF(IZREC*3+60 .GT. IARDIM) GO TO 8000
      NKTP = IENTAD + 80
      CALL DB2213(ICARD,12,2,NKT2)
      IF(NKT2 .LE. 0) GO TO 8020
      CALL DB2213(ICARD,3,6,IRETCD)
      IFLAG(20) = IRETCD
      ISTYP = 0
      ISLEN = ISTYP + IZREC
      ISDAT = ISLEN + IZREC
      ISZL = ISDAT + IZREC
      ISFRST = ISZL + 30
      JAN = ISZL + 1
      JEND = ISZL + 60
      DO 300 J = JAN,JEND
300   IAR(J) = 0
      IZ = 0
      IOFDAT = NKTP + 80*NKT2
      ITYPM = -1
      DO 600 NK = 1,NKT2
      CALL DB2317(ICSD,NKTP,ICARD,0,80,NBRAS)
      DO 500 IP = 1,76,5
      CALL DB2213(ICARD,IP,2,ITYP)
      CALL DB2213(ICARD,IP+2,3,ILEN)
      IF(ITYP .LE. 0) GO TO 8020
      IF(ITYP .GT. 30) GO TO 8020
      IF(ILEN .LE. 0) GO TO 8020
      IZ = IZ + 1
      IAR(IZ) = ITYP
      IAR(ISLEN+IZ) = ILEN
      IAR(ISDAT+IZ) = IOFDAT
      IOFDAT = IOFDAT + ILEN
      IF(ITYP .EQ. ITYPM) GO TO 400
      IAR(ISFRST+ITYP) = IZ
      IF(ITYPM .GT. 0) IAR(ISZL+ITYPM) = ITYPZL
      ITYPZL = 0
      ITYPM = ITYP
400   ITYPZL = ITYPZL + 1
      IF(IZ .EQ. IZREC) GO TO 800
500   CONTINUE
      NKTP = NKTP + 80
600   CONTINUE
800   IAR(ISZL+ITYP) = ITYPZL
      GO TO 9000
8000  IRETCD = -1
      GO TO 9000
8020  IRETCD = -2
9000  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2252
      SUBROUTINE DB2252(NTYP,NREC,IAR,NBRAS,NRC)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,ISFRST,NFLDS,IFLDAD(20),IFLDLN(20)
      DIMENSION IAR(*), NBRAS(*)
      IF(NTYP .GT. 30) GO TO 100
      IF(NTYP .LE. 0) GO TO 100
      IF (IAR(ISZL+NTYP) .LT. NREC) GO TO 80
      NRC = IAR(ISFRST+NTYP) + NREC - 1
      IF(NRC .GT. 0) CALL DB2254(NRC,IAR,NBRAS)
      RETURN
80    NRC=0
      RETURN
100   NRC = -1
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2254
      SUBROUTINE DB2254(NREC,IAR,NBRAS)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,ISFRST,NFLDS,IFLDAD(20),IFLDLN(20)
      DIMENSION IAR(*),NBRAS(*),IRDIR(6)
      IF(NREC .GT. IZREC) GO TO 8000
      IF(NREC .LE. 0) GO TO 8020
      IROFF = IAR(ISDAT+NREC)
      CALL DB2317(ICSD,IROFF,IRDIR,0,22,NBRAS)
      CALL DB2213(IRDIR,1,2,NFLDS)
      IF(NFLDS .GT. 20) GO TO 8020
      IRAD = IROFF + 2 + NFLDS
      IF(NFLDS .EQ. 0) GO TO 500
      JFP = 3
      DO 400 J = 1,NFLDS
      CALL DB2213(IRDIR,JFP,1,NRLN)
      IFLDLN(J) = NRLN
      IFLDAD(J) = IRAD
      IRAD = IRAD + NRLN
      JFP = JFP + 1
400   CONTINUE
      GO TO 9000
500   NFLDS = 1
      IFLDAD(1) = IROFF + 2
      IFLDLN(1) = IAR(ISLEN+NREC) - 2
      GO TO 9000
8000  NFLDS = 0
      GO TO 9000
8020  NFLDS = -1
9000  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2255
      SUBROUTINE DB2255(NFELD,IAFELD,LFELD)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,ISFRST,NFLDS,IFLAD(20),IFLDLN(20)
      IF(NFELD .GT. NFLDS) GO TO 8000
      IF(NFELD .LE. 0) GO TO 8020
      IAFELD = IFLAD(NFELD)
      LFELD = IFLDLN(NFELD)
      GO TO 9000
8000  LFELD = 0
      GO TO 9000
8020  LFELD = -1
9000  Continue
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD851021--DB2256
      SUBROUTINE DB2256(NRFELD,IAR,MAXLEN,LEN,NBRAS)
      DIMENSION IAR(*), NBRAS(*)
      CALL DB2260(NRFELD,IAR,MAXLEN,LEN,NBRAS)
      IF(LEN .GT. 0) CALL DB0212(IAR,LEN)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2257
      SUBROUTINE DB2257(IAR,NTYP,IZAHL)
      DIMENSION IAR(*)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,IFRST,NFLDS,IFLDAD(20),IFLDLN(20)
      IF(NTYP .LE. 0) GO TO 100
      IF(NTYP .GT. 30) GO TO 100
      IZAHL = IAR(ISZL+NTYP)
      RETURN
100   IZAHL = 0
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2258
      SUBROUTINE DB2258(NRFELD,IZAHL,IRC,NBRAS)
      DIMENSION NBRAS(*), IH(3)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,ISFRST,NFLDS,IFLAD(20),IFLDLN(20)
      IRC = 0
      IVZ = 1
      IZAHL = 0
      CALL DB2255(NRFELD,IA,LEN)
      IF(LEN .LE. 0) GO TO 500
      CALL DB2317(ICSD,IA,IH,0,LEN,NBRAS)
      DO 400 J = 1,LEN
      CALL CONVCI(IH,J,IZ)
      IF(IZ .GE. 0) GO TO 200
      IF(IZ .NE. -3) GO TO 600
      IVZ = -1
      GO TO 400
200   IZAHL = IZAHL*10 + IZ
400   CONTINUE
      IZAHL = IZAHL * IVZ
      GO TO 9000
500   IRC = -1
      GO TO 9000
600   IRC = -2
9000  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2259
      SUBROUTINE DB2259(NRFELD,ZA,IRETCD,NBRAS)
      DIMENSION IH(3),NBRAS(*)
       REAL ZA(1)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,IFRST,NFLDS,IFLDAD(20),IFLDLN(20)
      IRETCD = 0
      IVK = 0
      IVORZ = 1
      ZAHL = 0.0
      CALL DB2255(NRFELD,IAFELD,LFELD)
      IF(LFELD) 2000,2020,200
200   CALL DB2317(ICSD,IAFELD,IH,0,LFELD,NBRAS)
      JAN = 1
      CALL CONVCI(IH,1,IZIF)
      IF(IZIF) 300,700,600
300   IZIF = -IZIF
      GO TO (400,420,500,2000), IZIF
400   IZIF = 0
      GO TO 700
420   JAN = 2
      GO TO 940
500   IVORZ = -1
      JAN = 2
      GO TO 700
600   IVK = IZIF
      JAN = 2
      IF(LFELD .LE. 1) GO TO 840
700   DO 800 J = JAN,LFELD
      CALL CONVCI(IH,J,IZIF)
      IF(IZIF) 900,720,720
720   IVK = IVK * 10 + IZIF
800   CONTINUE
840   ZAHL = FLOAT(IVK*IVORZ)
      GO TO 9000
900   IF(IZIF .NE. -2) GO TO 2000
      JAN = J + 1
940   IEX = 1
      IF(JAN .GT. LFELD) GO TO 840
      INK = 0
      DO 1000 J = JAN,LFELD
      CALL CONVCI(IH,J,IZIF)
      IF(IZIF .LT. 0) GO TO 2000
      INK = INK*10 + IZIF
      IEX = IEX * 10
      IRETCD = IRETCD + 1
1000  CONTINUE
      ZAHL = FLOAT(IVK*IVORZ) + FLOAT(INK*IVORZ)/FLOAT(IEX)
      GO TO 9000
2000  IRETCD = -2
      GO TO 9000
2020  IRETCD = -1
9000  CONTINUE
      ZA(1) = ZAHL
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD851021--DB2260
      SUBROUTINE DB2260(NRFELD,IAR,MAXLEN,LEN,NBRAS)
      DIMENSION NBRAS(*),IAR(*)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,ISFRST,NFLDS,IFLDAD(20),IFLDLN(20)
      CALL DB2255(NRFELD,IAFELD,LFELD)
      IF(LFELD .LE. 0) GO TO 8000
      LEN = MIN0(LFELD,MAXLEN)
      CALL DB0101(ICSD,IAFELD,IAR,0,LEN,NBRAS)
      GO TO 9000
8000  LEN = 0
9000  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860922--DB2261
      SUBROUTINE DB2261(IAR,IARDIM,NBRAS,IRETCD,ITYPV)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,ISFRST,NFLDS,IFLDAD(20),IFLDLN(20)
      COMMON /DC2201/ IFLAG(50)
      DIMENSION IAR(*),NBRAS(*)
      IF(IZREC*3+60 .GT. IARDIM) GO TO 8000
      NKTP = IENTAD + 80
      CALL DB2213(ICARD,12,2,NKT2)
      IF(NKT2 .LE. 0) GO TO 8020
      CALL DB2213(ICARD,3,6,IRETCD)
      IFLAG(20) = IRETCD
      ISTYP = 0
      ISLEN = ISTYP + IZREC
      ISDAT = ISLEN + IZREC
      ISZL = ISDAT + IZREC
      ISFRST = ISZL + 30
      JAN = ISZL + 1
      JEND = ISZL + 60
      DO 300 J = JAN,JEND
300   IAR(J) = 0
      IZ = 0
      IOFDAT = NKTP + 80*NKT2
      ITYPM = -1
      DO 600 NK = 1,NKT2
      CALL DB2317(ICSD,NKTP,ICARD,0,80,NBRAS)
      DO 500 IP = 1,76,5
      CALL DB2213(ICARD,IP,2,ITYP)
      CALL DB2213(ICARD,IP+2,3,ILEN)
      IF(ITYP .LE. 0) GO TO 8020
      IF(ITYP .GT. 30) GO TO 8020
      IF(ILEN .LE. 0) GO TO 8020
      IZ = IZ + 1
      IAR(IZ) = ITYP
      IAR(ISLEN+IZ) = ILEN
      IAR(ISDAT+IZ) = IOFDAT
      IOFDAT = IOFDAT + ILEN
      IF(ITYP .EQ. ITYPM) GO TO 400
      IAR(ISFRST+ITYP) = IZ
      IF(ITYPM .GT. 0) IAR(ISZL+ITYPM) = ITYPZL
      ITYPZL = 0
      ITYPM = ITYP
400   ITYPZL = ITYPZL + 1
      IF(IZ .EQ. IZREC) GO TO 800
      IF(ITYP .GT. ITYPV) GO TO 800
500   CONTINUE
      NKTP = NKTP + 80
600   CONTINUE
800   IAR(ISZL+ITYP) = ITYPZL
      GO TO 9000
8000  IRETCD = -1
      GO TO 9000
8020  IRETCD = -2
9000  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2262
      SUBROUTINE DB2262(IFELD)
      DIMENSION IFELD(*)
      COMMON /DC2249/ ICSD,ICARD(20),IZREC,IENTAD,ISTYP,
     1ISLEN,ISDAT,ISZL,ISFRST,NFLDS,IFLDAD(20),IFLDLN(20)
      CALL CONVCI(ICARD,22,IFELD(1))
      IF(IFELD(1) .LT. 0) IFELD(1)=0
      IP = 23
      DO 100 J = 2,4
      CALL CONVCI(ICARD,IP,N)
      IF(N .LT. 0) N = 0
      IP = IP + 1
      CALL CONVCI(ICARD,IP,L)
      IF(L .LT. 0) L = 0
      IP = IP + 1
      IFELD(J) = 10*N + L
100   CONTINUE
      IP = 63
      DO 300 J = 5,7
      N = 0
      DO 200 K = 1,6
      CALL CONVCI(ICARD,IP,L)
      IP = IP + 1
      IF(L .LT. 0) L = 0
      N = N*10 + L
200   CONTINUE
      IFELD(J) = N
300   CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2280
      SUBROUTINE DB2280 (NTI,NTD,NTP)
C
C ***************************************************
C ----MAIN ROUTINE OF THE CRYSTIN COMMAND INTERPRETER
C ***************************************************
C
      DIMENSION KDO(64),ICLAR(30),NEWREL(4)
       INTEGER KDBLNX(1),KDMNUX(1),KDSEMX(1)
      DIMENSION IOUTBF(30)
      COMMON /DC2280/ NTIN,NTDSPL,NTPRT,KARTE(60),KARPOI,KAREND,KDSEMI
      COMMON /DC2280/ IVERFY(20)
      COMMON /DC2201/ IFLAG(50)
CHP8  DATA KDBLNK/'    '/,KDMNUS/'-'/,KDTRNZ/';'/
Cmw      DATAKDBLNK/Z'40404040'/,KDMNUS/Z'60404040'/,KDTRNZ/Z'5E404040'/
      DATAKDBLNK/Z'40404040'/,KDMNUS/Z'40404060'/,KDTRNZ/Z'4040405E'/
CHP8  DATA KDBLNX(1)/'    '/,KDMNUX(1)/'-'/
Cmw      DATAKDBLNX(1)/Z'40404040'/,KDMNUX(1)/Z'60404040'/
      DATAKDBLNX(1)/Z'40404040'/,KDMNUX(1)/Z'40404060'/
CHP8  DATA NEWREL/'NEWS','    ','RELE','ASE '/
Cmw      DATANEWREL/Z'D5C5E6E2',Z'40404040',Z'D9C5D3C5',Z'C1E2C540'/
      DATANEWREL/Z'E2E6C5D5',Z'40404040',Z'C5D3C5D9',Z'40C5E2C1'/
CHP8  DATA KDO/'DISP','LAY;','EN;E','ND;F','IND;','PRIN','T;RE','S;SH',
C    1 'OW;L','IST;','ARRA','YS;S','TRIN','G;FL','AGS;','MORE',
C    2 ';TIM','E;HE','LP;S','AVE;','PLOT',';GHE','LP;E','HELP',';BAS',
C    3 'E;X;','?;SC','AN;E','CHO;','NO;D','ISTA','NCES',';DEL','ETE;',
C    4 'LIST','USRN',';COM','PRES','S;NO','ECHO',';PDI','STAN','CES;',
C    5 'FIND','CODN',';RES','TART',';CLE','AR;N','OCLE','AR;C','ALL;',
C    6 'QUI;','QUIT',';SOR','T;AD','APTA','TION',';NEW','S;RE','LEAS',
C    7 'E;EL','ORDE','R!  '/
Cmw      DATAKDO/Z'C4C9E2D7',Z'D3C1E85E',Z'C5D55EC5',Z'D5C45EC6',Z'C9D5C45E
Cmw     $',Z'D7D9C9D5',Z'E35ED9C5',Z'E25EE2C8',Z'D6E65ED3',Z'C9E2E35E',Z'C1
Cmw     $D9D9C1',Z'E8E25EE2',Z'E3D9C9D5',Z'C75EC6D3',Z'C1C7E25E',Z'D4D6D9C5
Cmw     $',Z'5EE3C9D4',Z'C55EC8C5',Z'D3D75EE2',Z'C1E5C55E',Z'D7D3D6E3',Z'5E
Cmw     $C7C8C5',Z'D3D75EC5',Z'C8C5D3D7',Z'5EC2C1E2',Z'C55EE75E',Z'6F5EE2C3
Cmw     $',Z'C1D55EC5',Z'C3C8D65E',Z'D5D65EC4',Z'C9E2E3C1',Z'D5C3C5E2',Z'5E
Cmw     $C4C5D3',Z'C5E3C55E',Z'D3C9E2E3',Z'E4E2D9D5',Z'5EC3D6D4',Z'D7D9C5E2
Cmw     $',Z'E25ED5D6',Z'C5C3C8D6',Z'5ED7C4C9',Z'E2E3C1D5',Z'C3C5E25E',Z'C6
Cmw     $C9D5C4',Z'C3D6C4D5',Z'5ED9C5E2',Z'E3C1D9E3',Z'5EC3D3C5',Z'C1D95ED5
Cmw     $',Z'D6C3D3C5',Z'C1D95EC3',Z'C1D3D35E',Z'D8E4C95E',Z'D8E4C9E3',Z'5E
Cmw     $E2D6D9',Z'E35EC1C4',Z'C1D7E3C1',Z'E3C9D6D5',Z'5ED5C5E6',Z'E25ED9C5
Cmw     $',Z'D3C5C1E2',Z'C55EC5D3',Z'D6D9C4C5',Z'D95A4040'/
      DATAKDO/Z'D7E2C9C4',Z'5EE8C1D3',Z'C55ED5C5',Z'C65EC4D5',Z'5EC4D5C9
     $',Z'D5C9D9D7',Z'C5D95EE3',Z'C8E25EE2',Z'D35EE6D6',Z'5EE3E2C9',Z'C1
     $D9D9C1',Z'E25EE2E8',Z'D5C9D9E3',Z'D3C65EC7',Z'5EE2C7C1',Z'C5D9D6D4
     $',Z'D4C9E35E',Z'C5C85EC5',Z'E25ED7D3',Z'5EC5E5C1',Z'E3D6D3D7',Z'C5
     $C8C75E',Z'C55ED7D3',Z'D7D3C5C8',Z'E2C1C25E',Z'5EE75EC5',Z'C3E25E6F
     $',Z'C55ED5C1',Z'5ED6C8C3',Z'C45ED6D5',Z'C1E3E2C9',Z'E2C5C3D5',Z'D3
     $C5C45E',Z'5EC5E3C5',Z'E3E2C9D3',Z'D5D9E2E4',Z'D4D6C35E',Z'E2C5D9D7
     $',Z'D6D55EE2',Z'D6C8C3C5',Z'C9C4D75E',Z'D5C1E3E2',Z'5EE2C5C3',Z'C4
     $D5C9C6',Z'D5C4D6C3',Z'E2C5D95E',Z'E3D9C1E3',Z'C5D3C35E',Z'D55ED9C1
     $',Z'C5D3C3D6',Z'C35ED9C1',Z'5ED3D3C1',Z'5EC9E4D8',Z'E3C9E4D8',Z'D9
     $D6E25E',Z'C4C15EE3',Z'C1E3D7C1',Z'D5D6C9E3',Z'E6C5D55E',Z'C5D95EE2
     $',Z'E2C1C5D3',Z'D3C55EC5',Z'C5C4D9D6',Z'40405AD9'/
      IECHO = 0
      NTIN = NTI
      NTDSPL = NTD
      NTPRT = NTP
      INLN=72
      IFLAG(31) = INLN
C
C ---INITIALIZE TIME PROGRAM
      CALL DB2218(NTDSPL)
C
      ICLAR(1)=3
      ICLAR(2)=1
      ICLAR(3)=NTIN
      ICLAR(4)=NTDSPL
      ICLAR(5)=NTPRT
      DO 10 I=1,20
   10 IVERFY(I)=0
      CALL DB2201 (ICLAR,IADR,IRC)
      IF (IRC) 20,40,20
   20 WRITE (NTDSPL,30)
   30 FORMAT (' DB2280 - System cannot start.')
      GO TO 9990
   40 KDSEMI=KDTRNZ
      IRC=0
   50 KARBEG=1
      KAREND=1
      WRITE (NTDSPL,60)
   60 FORMAT (' Command? ')
   70 CONTINUE
      CALL KEYBRD(NTIN,ICLAR,20)
      CALL CICDCS (ICLAR,1,120,IOUTBF)
      IF (IECHO .NE. 0) WRITE (NTDSPL,80) (IOUTBF(I),I=1,17)
   80 FORMAT (' ',17A4)
      J=INLN
   90 IF (LCOMPS(ICLAR,J,1,KDBLNX(1),1)) 120,100,120
  100 J=J-1
      IF (J) 110,110,90
  110 IF (KAREND-1) 50,50,70
  120 IF (KAREND+J-236) 150,150,130
  130 WRITE (NTDSPL,140)
  140 FORMAT (' Input too long.')
      GO TO 50
  150 CALL COPYCH (ICLAR,1,J,KARTE,KAREND)
      KAREND=KAREND+J
      IF (LCOMPS(ICLAR,J,1,KDMNUX(1),1)) 190,160,190
  160 IF (J-1) 190,190,170
  170 IF (LCOMPS(ICLAR,J-1,1,KDBLNX(1),1)) 190,180,190
  180 KAREND=KAREND-1
      GO TO 70
  190 CALL COPYCH (KDBLNX(1),1,4,KARTE,KAREND)
  200 KARPOI=0
  210 KARPOI=KARPOI+1
      CALL DB2288 (KARTE,KARPOI,KAREND,KDO,I)
      IF (I) 220,240,260
  220 IF (KARPOI-KAREND) 230,50,50
  230 IRC=5
      GO TO 1170
  240 CALL DB2284
      WRITE (NTDSPL,250)
  250 FORMAT (' Command not found')
      GO TO 50
  260 GO TO (270,240,1400,350,390,240,390,370,380,430,440,520,580,610,
     1  680,390,590,600,730,770,610,800,810,240,830,680,710,720,820,
     2  830,960,340,980,990,550,240,9990,1010,1080,630,640,1000),I
  270 CALL DB2283 (KARPOI,ICLAR,IRC)
  280 IF (IRC) 360,310,290
  290 IF (IRC-1) 310,300,1160
  300 ICLAR(4) = 0
  310 ICLAR(2)=2
  320 CALL DB2201 (ICLAR,IADR,IRC)
  330 IF (IRC) 360,1100,50
  340 ICLAR(1)=3
      ICLAR(3)=0
      CALL DB2286 (KARTE,KARPOI,KAREND,ICLAR(3),IRC)
      GO TO 280
  350 CALL DB2281 (IRC)
      IF (IRC) 360,1100,1160
  360 IF (IRC+2) 1120,1120,1140
  370 CALL DB2287 (KARTE,KARPOI,KAREND,ICLAR(3),IRC)
      ICLAR(1)=4
      ICLAR(2)=3
      GO TO 320
  380 ICLAR(1)=2
      ICLAR(2)=9
      GO TO 320
  390 CALL DB2287(KARTE,KARPOI,KAREND,ICLAR(3),IRC)
      CALL DB2285(ICLAR(4),IRC)
      IF (IRC) 360,400,1160
  400 ICLAR(1)=4
      ICLAR(2)=1
      IF (I-7) 410,320,420
  410 ICLAR(2)=2
      GO TO 320
  420 ICLAR(2)=5
      IFLAG(22)=0
      IF (ICLAR(5) .EQ. 13) IFLAG(22)=1
      GO TO 320
  430 CALL DB2302 (KARPOI,ICLAR,IRC)
      IF (IRC) 360,320,1160
  440 CALL DB2286 (KARTE,KARPOI,KAREND,IZAHL,IRC)
      IF (IRC) 360,460,450
  450 IF (IRC-2) 1100,1240,1240
  460 IZ=IABS(IZAHL)
      IF (IZ) 1320,1320,470
  470 IF (IZ-4) 480,480,510
  480 I=0
      IF (IZAHL) 500,500,490
  490 I=NTDSPL
  500 IVERFY(IZ)=I
      GO TO 440
  510 ICLAR(1)=3
      ICLAR(2)=3
      ICLAR(3)=IZAHL
      CALL DB2201 (ICLAR,IADR,IRC)
      IF (IRC) 360,440,50
  520 CALL DB2286 (KARTE,KARPOI,KAREND,IZAHL,IRC)
      IF (IRC) 360,540,530
  530 IF (IRC-2) 1100,1240,1200
  540 ICLAR(1)=3
      ICLAR(2)=4
      ICLAR(3)=IZAHL
      GO TO 320
  550 CALL DB2286 (KARTE,KARPOI,KAREND,IZAHL,IRC)
      IF (IRC) 360,570,560
  560 IF (IRC-2) 1100,1240,1200
  570 ICLAR(1)=3
      ICLAR(2)=7
      ICLAR(3)=IZAHL
      GO TO 320
  580 CALL DB2218 (NTDSPL)
      GO TO 1100
  590 ICLAR(5)=1
      GO TO 620
  600 ICLAR(5)=2
      GO TO 620
  610 ICLAR(5)=0
  620 CALL DB2289 (KARTE,KARPOI,KAREND,ICLAR(2),8,IRC)
      IF (IRC) 360,660,1160
  630 I=1
      GO TO 650
  640 I=3
  650 ICLAR(5)=0
      ICLAR(3)=NEWREL(I)
      ICLAR(4)=NEWREL(I+1)
  660 ICLAR(1)=5
  670 ICLAR(2)=1
      GO TO 320
  680 CALL DB2289 (KARTE,KARPOI,KAREND,ICLAR(2),8,IRC)
      IF (IRC) 360,690,1160
  690 ICLAR(1)=5
      IF (ICLAR(2)) 1220,1200,700
  700 ICLAR(2)=2
      IF (I .EQ. 26) ICLAR(2)=3
      GO TO 320
  710 ICLAR(1)=5
      ICLAR(2)=4
      GO TO 320
  720 ICLAR(1)=5
      ICLAR(2)=5
      GO TO 320
  730 ICLAR(1)=3
      ICLAR(2)=5
      I=3
  740 I=I+1
      IF (I-30) 750,750,1380
  750 CALL DB2286 (KARTE,KARPOI,KAREND,ICLAR(I),IRC)
      IF (IRC-1) 740,760,1240
  760 ICLAR(3)=I-4
      GO TO 320
  770 DO 780 I=1,30
  780 ICLAR(I)=KDBLNK
      LEN=KAREND-KARPOI
      IF (LEN-120) 790,790,1220
  790 IF (LEN .LE. 0) GO TO 50
      CALL COPYCH (KARTE,KARPOI,LEN,ICLAR,1)
      CALL XCMD (ICLAR,LEN)
      GO TO 50
  800 CALL DB2287 (KARTE,KARPOI,KAREND,INLN,I)
      INLN=MIN0(80,INLN)
      INLN=MAX0(20,INLN)
      IFLAG(31) = INLN
      GO TO 1100
  810 IECHO=1
      GO TO 1100
  820 IECHO=0
      GO TO 1100
  830 DO 840 J=4,30
  840 ICLAR(J)=KDBLNK
      ICLAR(1)=6
      ICLAR(2)=1
      CALL DB2287 (KARTE,KARPOI,KAREND,ICLAR(3),IRC)
      IF (IRC) 850,850,870
  850 IF (ICLAR(3)) 860,860,870
  860 IRC=8
      GO TO 1170
  870 IF (I-30) 890,880,890
  880 ICLAR(2)=3
  890 I=KARPOI
      GO TO 910
  900 KARPOI=KARPOI+1
  910 KDSEMX(1) = KDSEMI
      IF (LCOMPS(KARTE,KARPOI,1,KDSEMX(1),1)) 920,930,920
  920 IF (KARPOI-KAREND) 900,930,930
  930 LEN=KARPOI-I+1
      IF (LEN-108) 940,940,950
  940 CALL COPYCH (KARTE,I,LEN,ICLAR,13)
      GO TO 320
  950 IRC=7
      GO TO 1160
  960 CALL DB2289 (KARTE,KARPOI,KAREND,ICLAR(3),100,IRC)
      IF (IRC) 360,970,1160
  970 ICLAR(1)=3
      ICLAR(2)=6
      GO TO 320
  980 IFLAG(37)=0
      GO TO 1100
  990 IFLAG(37)=1
      GO TO 1100
 1000 ICLAR(2)=7
      GO TO 1020
 1010 ICLAR(2)=6
 1020 ICLAR(1)=4
      J=0
 1030 CALL DB2289 (KARTE,KARPOI,KAREND,ICLAR(29),4,IRC)
      IF (IRC) 1170,1040,1170
 1040 IF (ICLAR(29)) 1070,1070,1050
 1050 J=J+1
      IF(J-25) 1060,1060,1380
 1060 ICLAR(J+3)=ICLAR(30)
      GO TO 1030
 1070 ICLAR(3)=J
      GO TO 320
 1080 ICLAR(1)=2
      ICLAR(2)=10
      GO TO 320
 1090 KARPOI=KARPOI+1
 1100 IF (KARPOI-KAREND) 1110,50,50
 1110 KDSEMX(1) = KDSEMI
      IF (LCOMPS(KARTE,KARPOI,1,KDSEMX(1),1)) 1090,210,1090
 1120 WRITE (NTDSPL,1130)
 1130 FORMAT (' DB2280 - Severe system error. Use RESTART command.')
      GO TO 50
 1140 WRITE (NTDSPL,1150)
 1150 FORMAT (' DB2280 - Insufficient workspace generated.',
     1' Use RESTART command.')
      GO TO 50
 1160 IF (IRC-6) 1170,50,1170
 1170 CALL DB2284
      GO TO (1200,1220,1240,1260,1280,50,1300,1320,1340,1360,1180),IRC
 1180 WRITE (NTDSPL,1190)
 1190 FORMAT (' ILLEGAL RETURN-CODE:',I10)
      GO TO 50
 1200 WRITE (NTDSPL,1210)
 1210 FORMAT (' Operand missing or incomplete.')
      GO TO 50
 1220 WRITE (NTDSPL,1230)
 1230 FORMAT (' String too long.')
      GO TO 50
 1240 WRITE (NTDSPL,1250)
 1250 FORMAT (' Unexpected character.')
      GO TO 50
 1260 WRITE (NTDSPL,1270)
 1270 FORMAT (' Missing closing quote.')
      GO TO 50
 1280 WRITE (NTDSPL,1290)
 1290 FORMAT (' SYNTAX-ERROR.')
      GO TO 50
 1300 WRITE (NTDSPL,1310)
 1310 FORMAT (' Invalid type.')
      GO TO 50
 1320 WRITE (NTDSPL,1330)
 1330 FORMAT (' Number out of range.')
      GO TO 50
 1340 WRITE (NTDSPL,1350)
 1350 FORMAT (' Keyword ambiguous.')
      GO TO 50
 1360 WRITE (NTDSPL,1370)
 1370 FORMAT (' Type invalid or may not be scanned.')
      GO TO 50
 1380 WRITE (NTDSPL,1390)
 1390 FORMAT (' Too many operands.')
      GO TO 50
 1400 WRITE (NTDSPL,1410)
 1410 FORMAT (' Please type QUIT to terminate your CRYSTIN session.')
      GO TO 50
 9990 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2281
      SUBROUTINE DB2281 (IRC)
      DIMENSION IAKT(40),ISYMB(40),NAME(40),LOPR(3),IGTFLS(30)
      DIMENSION ICLAR(21),IADRBF(40),IGTADR(30)
       DIMENSION LBUBLK(1),LBUKLA(1),LBAZ09(1),KDSEMX(1)
       DIMENSION LBUKLZ(1),LOAD(1),LBUNR(1),LBUQ(1)
       DIMENSION LFNAME(1),IDELNM(1)
      DIMENSION IOUTBF(30)
      COMMON /DC2280/ NTIN,NTDSPL,NTPRT,KARTE(60),KARPOI,KAREND,KDSEMI
      COMMON /DC2280/ IVERFY(20)
      DATA IGTDIM/30/,ISPDIM/40/
CHP8  DATA LAST/'LAST'/,IDEL/'DELD'/,LELE/'ELE '/
Cmw      DATALAST/Z'D3C1E2E3'/,IDEL/Z'C4C5D3C4'/,LELE/Z'C5D3C540'/
      DATALAST/Z'E3E2C1D3'/,IDEL/Z'C4D3C5C4'/,LELE/Z'40C5D3C5'/
CHP8  DATA LOPR/'NOT ','OR  ','AND '/,ISYMB/40*0/
Cmw      DATALOPR/Z'D5D6E340',Z'D6D94040',Z'C1D5C440'/,ISYMB/40*0/
      DATALOPR/Z'40E3D6D5',Z'4040D9D6',Z'40C4D5C1'/,ISYMB/40*0/
CHP8  DATA LBUBLK(1)/' '/,LBUKLA(1)/'('/,LBAZ09(1)/'AZ09'/
Cmw      DATALBUBLK(1)/Z'40404040'/,LBUKLA(1)/Z'4D404040'/,LBAZ09(1)/Z'C1E9
Cmw     $F0F9'/
      DATALBUBLK(1)/Z'40404040'/,LBUKLA(1)/Z'4040404D'/,LBAZ09(1)/Z'F9F0
     $E9C1'/
CHP8  DATA LBUKLZ(1)/')'/,LOAD(1)/'LOAD'/,LBUNR(1)/'#'/
Cmw      DATALBUKLZ(1)/Z'5D404040'/,LOAD(1)/Z'D3D6C1C4'/,LBUNR(1)/Z'7B40404
Cmw     $0'/
      DATALBUKLZ(1)/Z'4040405D'/,LOAD(1)/Z'C4C1D6D3'/,LBUNR(1)/Z'4040407
     $B'/
CHP8  DATA LBUQ(1)/'Q'/,KDSEMX/';'/
Cmw      DATALBUQ(1)/Z'D8404040'/,KDSEMX/Z'5E404040'/
      DATALBUQ(1)/Z'404040D8'/,KDSEMX/Z'4040405E'/
      KARPOI=KARPOI-1
      NRLAST=0
      IGTPOI=0
      IAKT(1)=7
      ISP=2
   10 IAKT(ISP)=2
      NAME(ISP)=IDEL
   20 IF (KARPOI-KAREND) 30,310,310
   30 KARPOI=KARPOI+1
      IF (LCOMPS(KARTE,KARPOI,1,LBUBLK(1),1)) 40,20,40
   40 IF (LCOMPS(KARTE,KARPOI,1,LBUKLA(1),1)) 50,100,50
   50 IF (LCOMPS(KARTE,KARPOI,1,LBAZ09(1),1)) 70,170,60
   60 IF (LCOMPS(KARTE,KARPOI,1,LBAZ09(1),2)) 170,170,70
   70 IF (LCOMPS(KARTE,KARPOI,1,LBAZ09(1),3)) 90,170,80
   80 IF (LCOMPS(KARTE,KARPOI,1,LBAZ09(1),4)) 170,170,90
   90 IRC=3
      GO TO 1140
  100 IF (IAKT(ISP)-2) 110,150,110
  110 IF (ISP-ISPDIM) 140,120,120
  120 WRITE (NTDSPL,130)
  130 FORMAT (' DB2281-130 Stack-overflow.')
      IRC=6
      GO TO 1140
  140 ISP=ISP+1
      NAME(ISP)=IDEL
  150 IAKT(ISP)=6
      IF (ISP-ISPDIM) 160,120,120
  160 ISP=ISP+1
      GO TO 10
  170 ISYMB(ISP)=KARPOI
      NAME(ISP)=LOAD(1)
      CALL DB2283 (KARPOI,ICLAR,IRC)
      IF (IRC) 1140,180,1140
  180 IF (ISP-ISPDIM) 190,120,120
  190 ISP=ISP+1
      NAME(ISP)=IDEL
      IOPR=0
      IF (KARPOI-KAREND) 220,220,360
  200 IOPR=0
      IF (KARPOI-KAREND) 210,360,360
  210 KARPOI=KARPOI+1
  220 IF (LCOMPS(KARTE,KARPOI,1,LBUBLK(1),1)) 230,200,230
  230 IF (LCOMPS(KARTE,KARPOI,1,KDSEMX(1),1)) 240,360,240
  240 IF (LCOMPS(KARTE,KARPOI,1,LBUKLZ(1),1)) 250,350,250
  250 IF (LCOMPS(KARTE,KARPOI,3,LOPR(1),1)) 260,280,260
  260 IF (LCOMPS(KARTE,KARPOI,2,LOPR(2),1)) 270,290,270
  270 IF (LCOMPS(KARTE,KARPOI,3,LOPR(3),1)) 310,300,310
  280 KARPOI=KARPOI+2
      GO TO 340
  290 KARPOI=KARPOI+1
      GO TO 330
  300 KARPOI=KARPOI+2
      GO TO 320
  310 IRC=1
      GO TO 1140
  320 IOPR=IOPR+1
  330 IOPR=IOPR+1
  340 IOPR=IOPR+2
  350 IOPR=IOPR+1
  360 IAKT(ISP)=IOPR
  370 IF (IAKT(ISP)-IAKT(ISP-1)) 380,380,20
  380 IF (IAKT(ISP-1)-2) 890,890,390
  390 IF (IAKT(ISP-1)-6) 400,890,890
  400 IF (LCOMPS(NAME(ISP-2),1,4,LOAD(1),1)) 540,410,540
  410 CALL DB2282 (LFNAME(1))
      CALL COPYCH (LBUQ(1),1,1,LFNAME(1),1)
      IF (IGTPOI-IGTDIM) 440,420,420
  420 WRITE (NTDSPL,430)
  430 FORMAT (' DB2281-430 TOO MANY FILES TO HANDLE.')
      IRC=6
      GO TO 1140
  440 ISPP=ISP-2
      NAME(ISPP)=LFNAME(1)
      KARPOT=ISYMB(ISPP)
      ASSIGN 540 TO ITRET
  450 IGTPOI=IGTPOI+1
      IGTFLS(IGTPOI)=LFNAME(1)
      CALL DB2283 (KARPOT,ICLAR,IRC)
      IF (ICLAR(5) .NE. LAST) GO TO 460
      IF (ICLAR(3) .EQ. LELE) NRLAST=1
  460 IF (IVERFY(1)) 470,490,470
  470 CALL CICDCS (ICLAR,1,84,IOUTBF)
      CALL CICDCS (LFNAME(1),1,4,IOUTBF(22))
      WRITE (NTDSPL,480) IOUTBF(3),(IOUTBF(I),I=5,12),
     1                   (IOUTBF(I),I=14,21),IOUTBF(22)
  480 FORMAT (' GET   ',9A4,' TO ',8A4,/,7X,'NAME = ',A4)
  490 CALL DB2201 (ICLAR,IADR,IRC)
      IF (IRC) 530,500,530
  500 IADRBF(ISPP)=IADR
      IGTADR(IGTPOI)=IADR
      IF (NRLAST) 510,520,510
  510 NRLAST=0
      IGTPOI=IGTPOI-1
  520 GO TO ITRET,(540,570,1030)
  530 IGTPOI=IGTPOI-1
      GO TO 1140
  540 IF (LCOMPS(NAME(ISP-1),1,4,LOAD(1),1)) 570,550,570
  550 CALL DB2282 (LFNAME(1))
      CALL COPYCH (LBUQ(1),1,1,LFNAME(1),1)
      IF (IGTPOI-IGTDIM) 560,420,420
  560 ISPP=ISP-1
      NAME(ISPP)=LFNAME(1)
      KARPOT=ISYMB(ISPP)
      ASSIGN 570 TO ITRET
      GO TO 450
  570 IOPR=IAKT(ISP-1)-2
  580 IF (LCOMPS(NAME(ISP-2),1,1,LBUNR(1),1)) 590,780,590
  590 IF (IOPR-2) 620,600,600
  600 IF (LCOMPS(NAME(ISP-1),1,1,LBUNR(1),1)) 620,610,620
  610 LFNAME(1)=NAME(ISP-2)
      NAME(ISP-2)=NAME(ISP-1)
      NAME(ISP-1)=LFNAME(1)
      LFNAME(1)=IADRBF(ISP-2)
      IADRBF(ISP-2)=IADRBF(ISP-1)
      IADRBF(ISP-1)=LFNAME(1)
      GO TO 780
  620 CALL DB2282(LFNAME(1))
      IF (IVERFY(1)) 630,650,630
  630 CALL CICDCS (NAME(ISP-2),1,4,IOUTBF(1))
      CALL CICDCS (LFNAME(1),1,4,IOUTBF(2))
      WRITE (NTDSPL,640) IOUTBF(1),IOUTBF(2)
  640 FORMAT (' COPY  ',A4,' TO ',A4)
  650 ICLAR(1)=2
      ICLAR(2)=1
      ICLAR(3)=IADRBF(ISP-2)
      CALL DB2201 (ICLAR,IADR,IRC)
      IF (IRC) 1140,660,1140
  660 ASSIGN 770 TO IDELRT
      IDELNM(1)=NAME(ISP-2)
  670 IDELNR=0
      GO TO 690
  680 IDELNR=IDELNR+1
      IF (IDELNM(1) .EQ. IGTFLS(IDELNR)) GO TO 700
  690 IF (IDELNR-IGTPOI) 680,760,760
  700 IF (IVERFY(1)) 710,720,710
  710 CALL CICDCS (IDELNM(1),1,4,IOUTBF(1))
      WRITE (NTDSPL,1230) IOUTBF(1)
  720 ICLAR(1)=2
      ICLAR(2)=6
      ICLAR(3)=IGTADR(IDELNR)
      CALL DB2201 (ICLAR,IADR,IRC)
      IF (IRC) 1140,740,1140
  730 IDELNR=IDELNR+1
      IGTFLS(IDELNR-1)=IGTFLS(IDELNR)
      IGTADR(IDELNR-1)=IGTADR(IDELNR)
  740 IF (IDELNR-IGTPOI) 730,750,750
  750 IGTPOI=IGTPOI-1
  760 GO TO IDELRT, (770,880)
  770 IADRBF(ISP-2)=IADR
      NAME(ISP-2)=LFNAME(1)
  780 IF (IVERFY(1)) 790,810,790
  790 CALL CICDCS (LOPR(IOPR),1,4,IOUTBF(1))
      CALL CICDCS (NAME(ISP-2),1,8,IOUTBF(2))
      WRITE (NTDSPL,800) IOUTBF(1),IOUTBF(2),IOUTBF(3)
  800 FORMAT (' ',A4,2X,A4,',',A4)
  810 ICLAR(1)=2
      ICLAR(2)=IOPR+2
      ICLAR(3)=IADRBF(ISP-2)
      ICLAR(4)=IADRBF(ISP-1)
      CALL DB2201 (ICLAR,IADR,IRC)
      IF (IRC) 1140,820,1140
  820 IDELNM(1)=NAME(ISP-1)
      IF (LCOMPS(IDELNM(1),1,1,LBUNR(1),1)) 870,830,870
  830 IF (IVERFY(1)) 840,860,840
  840 CALL CICDCS (IDELNM(1),1,4,IOUTBF(1))
      WRITE (NTDSPL,850) IOUTBF(1)
  850 FORMAT (' DEL   ',A4)
  860 ICLAR(1)=2
      ICLAR(2)=2
      ICLAR(3)=IADRBF(ISP-1)
      CALL DB2201 (ICLAR,IADR,IRC)
      IF (IRC) 1140,880,1140
  870 ASSIGN 880 TO IDELRT
      GO TO 670
  880 IAKT(ISP-1)=IAKT(ISP)
      NAME(ISP)=IDEL
      ISP=ISP-1
      NAME(ISP)=IDEL
      GO TO 370
  890 IF (IAKT(ISP)-1) 970,900,20
  900 IF (IAKT(ISP-2)-6) 910,930,910
  910 CALL DB2284
      WRITE (NTDSPL,920)
  920 FORMAT (' TOO MANY CLOSING PARENTHESIS.')
      IRC=6
      GO TO 1140
  930 IF (IAKT(ISP-3)-6) 940,950,950
  940 ISYMB(ISP-3)=ISYMB(ISP-1)
      NAME(ISP-3)=NAME(ISP-1)
      IADRBF(ISP-3)=IADRBF(ISP-1)
      NAME(ISP-2)=IDEL
      ISP=ISP-2
      GO TO 200
  950 IAKT(ISP-2)=IAKT(ISP-1)
  960 ISYMB(ISP-2)=ISYMB(ISP-1)
      NAME(ISP-2)=NAME(ISP-1)
      IADRBF(ISP-2)=IADRBF(ISP-1)
      NAME(ISP-1)=IDEL
      ISP=ISP-1
      GO TO 200
  970 IF (IAKT(ISP-2)-7) 980,1000,980
  980 CALL DB2284
      WRITE (NTDSPL,990)
  990 FORMAT (' TOO FEW CLOSING PARENTHESES.')
      IRC=6
      GO TO 1140
 1000 IF (LCOMPS(NAME(2),1,4,LOAD(1),1)) 1070,1010,1070
 1010 CALL DB2282(LFNAME(1))
      CALL COPYCH (LBUQ(1),1,1,LFNAME(1),1)
      IF (IGTPOI-IGTDIM) 1020,420,420
 1020 NAME(2)=LFNAME(1)
      KARPOT=ISYMB(2)
      ISPP=2
      ASSIGN 1030 TO ITRET
      GO TO 450
 1030 CALL DB2282(LFNAME(1))
      IF (IVERFY(1)) 1040,1050,1040
 1040 CALL CICDCS (NAME(2),1,4,IOUTBF(1))
      CALL CICDCS (LFNAME(1),1,4,IOUTBF(2))
      WRITE (NTDSPL,640) IOUTBF(1),IOUTBF(2)
 1050 ICLAR(1)=2
      ICLAR(2)=1
      ICLAR(3)=IADRBF(2)
      CALL DB2201 (ICLAR,IADR,IRC)
      IF (IRC) 1140,1060,1140
 1060 IADRBF(2)=IADR
      NAME(2)=LFNAME(1)
 1070 IF (IVERFY(1)) 1080,1100,1080
 1080 CALL CICDCS (NAME(2),1,4,IOUTBF(1))
      WRITE (NTDSPL,1090) IOUTBF(1)
 1090 FORMAT (' RENAM ',A4,' TO LAST')
 1100 NAME(2)=LAST
      ICLAR(1)=2
      ICLAR(2)=7
      ICLAR(3)=IADRBF(2)
      CALL DB2201 (ICLAR,IADR,IRC)
      IF (IRC+1) 9990,1140,1110
 1110 IF (IVERFY(1)) 1120,1140,1120
 1120 WRITE (NTDSPL,1130)
 1130 FORMAT (' OPERATION COMPLETE.')
 1140 IF (ISP-2) 1200,1150,1150
 1150 IF (LCOMPS(NAME(ISP),1,1,LBUNR(1),1)) 1190,1160,1190
 1160 IF (IVERFY(1)) 1170,1180,1170
 1170 CALL CICDCS (NAME(ISP),1,4,IOUTBF(1))
      WRITE (NTDSPL,850) IOUTBF(1)
 1180 NAME(ISP)=IDEL
      ICLAR(1)=2
      ICLAR(2)=2
      ICLAR(3)=IADRBF(ISP)
      CALL DB2201 (ICLAR,IADR,IRCDMY)
 1190 ISP=ISP-1
      GO TO 1140
 1200 IF (IGTPOI) 9990,9990,1210
 1210 DO 1250 I=1,IGTPOI
      IF (IVERFY(1)) 1220,1240,1220
 1220 CALL CICDCS (IGTFLS(I),1,4,IOUTBF(1))
      WRITE (NTDSPL,1230) IOUTBF(1)
 1230 FORMAT (' FREE  ',A4)
 1240 ICLAR(1)=2
      ICLAR(2)=6
      ICLAR(3)=IGTADR(I)
      CALL DB2201 (ICLAR,IADR,IRCDMY)
 1250 CONTINUE
 9990 RETURN
      END
C ----------------------------------------OWNUNC411----UPD850814--DB2282
      SUBROUTINE DB2282 (LFNAME)
      DIMENSION ITAB(3),IZFTAB(3),LFNAME(*)
       DIMENSION NAMEX(1)
      DATA NR/0/,ITAB/100,10,1/
CHP8  DATA NAMEX(1)/'#000'/
Cmw      DATANAMEX(1)/Z'7BF0F0F0'/
      DATANAMEX(1)/Z'F0F0F07B'/
CHP8  DATA IZFTAB/'0123','4567','89  '/
Cmw      DATAIZFTAB/Z'F0F1F2F3',Z'F4F5F6F7',Z'F8F94040'/
      DATAIZFTAB/Z'F3F2F1F0',Z'F7F6F5F4',Z'4040F9F8'/
      NR=NR+1
      NRV=NR
      DO 40 J=1,3
      I=0
      GO TO 20
   10 I=I+1
      NRV=NRSV
   20 NRSV=NRV-ITAB(J)
      IF (NRSV) 30,10,10
   30 CALL COPYCH (IZFTAB,I+1,1,NAMEX(1),J+1)
   40 CONTINUE
      LFNAME(1)=NAMEX(1)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD861217--DB2283
      SUBROUTINE DB2283 (KARPOI,ICLAR,IRC)
      DIMENSION ICLAR(*)
       DIMENSION KDBLNX(1),KDTRNX(1),KDLTZX(1),KDSTRX(1),KDAPOX(1)
       DIMENSION KDGLZX(1),KDSEMX(1),KDTOX(1)
      COMMON /DC2280/ NTIN,NTDSPL,NTPRT,KARTE(60),KARPOT,KAREND,KDSEMI
      COMMON /DC2280/ IVERFY(20)
CHP8  DATA KDBLNX(1)/'    '/,KDTRNX(1)/' ;)='/
Cmw      DATAKDBLNX(1)/Z'40404040'/,KDTRNX(1)/Z'405E5D7E'/
      DATAKDBLNX(1)/Z'40404040'/,KDTRNX(1)/Z'7E5D5E40'/
CHP8  DATA KDLTZX(1)/'AZ09'/,KDSTRX(1)/'*'/
Cmw      DATAKDLTZX(1)/Z'C1E9F0F9'/,KDSTRX(1)/Z'5C404040'/
      DATAKDLTZX(1)/Z'F9F0E9C1'/,KDSTRX(1)/Z'4040405C'/
CHP8  DATA KDAPOX(1)/''''/,KDGLZX(1)/'='/,KDTOX(1)/'TO '/
Cmw      DATAKDAPOX(1)/Z'7D404040'/,KDGLZX(1)/Z'7E404040'/,KDTOX(1)/Z'E3D64
Cmw     $040'/
      DATAKDAPOX(1)/Z'4040407D'/,KDGLZX(1)/Z'4040407E'/,KDTOX(1)/Z'4040D
     $6E3'/
CHP8  DATA KDELE/'ELE '/,KDBLNK/'    '/,KDLTZF/'AZ09'/,KDAPO/''''/
Cmw      DATAKDELE/Z'C5D3C540'/,KDBLNK/Z'40404040'/,KDLTZF/Z'C1E9F0F9'/,KDA
Cmw     $PO/Z'7D404040'/
      DATAKDELE/Z'40C5D3C5'/,KDBLNK/Z'40404040'/,KDLTZF/Z'F9F0E9C1'/,KDA
     $PO/Z'4040407D'/
CHP8  DATA KDGLZ/'='/,KDTO/'TO '/,KDTRNZ/' ;)='/,KDSTRN/'*'/
Cmw      DATAKDGLZ/Z'7E404040'/,KDTO/Z'E3D64040'/,KDTRNZ/Z'405E5D7E'/,KDSTR
Cmw     $N/Z'5C404040'/
      DATAKDGLZ/Z'4040407E'/,KDTO/Z'4040D6E3'/,KDTRNZ/Z'7E5D5E40'/,KDSTR
     $N/Z'4040405C'/
      DATA L2/2/,L3/3/,L4/4/,L5/5/,L13/13/
      ICLAR(1)=1
      ICLAR(L2)=1
      ICLAR(L3)=KDELE
      ICLAR(L4)=0
      ICLAR(L13)=0
      IRC=0
      ISTUS=0
      DO 10 I=1,8
      ICLAR(I+4)=KDBLNK
      ICLAR(I+13)=KDBLNK
   10 CONTINUE
   20 IPTR=16
      GO TO 60
   30 IF (KARPOI-KAREND) 50,40,40
   40 IRC=1
      GO TO 999
   50 KARPOI=KARPOI+1
   60 IF (LCOMPS(KARTE,KARPOI,1,KDBLNX(1),1)) 70,30,70
   70 IF (LCOMPS(KARTE,KARPOI,1,KDTRNX(1),2)) 75,40,75
   75 ICNT=0
      IF (LCOMPS(KARTE,KARPOI,1,KDLTZX(1),1)) 90,110,80
   80 IF (LCOMPS(KARTE,KARPOI,1,KDLTZX(1),2)) 110,110,90
   90 IF (LCOMPS(KARTE,KARPOI,1,KDLTZX(1),3)) 101,110,100
  100 IF (LCOMPS(KARTE,KARPOI,1,KDLTZX(1),4)) 110,110,101
  101 IF (LCOMPS(KARTE,KARPOI,1,KDSTRX(1),1)) 190,110,190
  110 ICNT=ICNT+1
  120 IPTR=IPTR+1
      CALL COPYCH (KARTE,KARPOI,1,ICLAR,IPTR)
      IF (KARPOI-KAREND) 130,280,280
  130 KARPOI=KARPOI+1
      DO 150 JJ=1,4
      IF (LCOMPS(KARTE,KARPOI,1,KDTRNX(1),JJ)) 150,280,150
  150 CONTINUE
      IF (ICNT-31) 110,180,180
  180 IRC=2
      GO TO 999
  190 IF (LCOMPS(KARTE,KARPOI,1,KDAPOX(1),1)) 200,220,200
  200 IRC=3
      GO TO 999
  210 ICNT=ICNT+1
      IPTR=IPTR+1
      CALL COPYCH (KARTE,KARPOI,1,ICLAR,IPTR)
  220 IF (KARPOI-KAREND) 240,230,230
  230 IRC=4
      GO TO 999
  240 KARPOI=KARPOI+1
      IF (LCOMPS(KARTE,KARPOI,1,KDAPOX(1),1)) 270,250,270
  250 IF (KARPOI-KAREND) 260,440,440
  260 KARPOI=KARPOI+1
      IF (LCOMPS(KARTE,KARPOI,1,KDAPOX(1),1)) 280,270,280
  270 IF (ICNT-31) 210,180,180
  280 IF (ISTUS-1) 290,290,300
  290 ICLAR(L4)=ICNT
      IF (KARPOI-KAREND) 330,435,440
  300 ICLAR(L13)=ICNT
      GO TO 999
  310 IF (KARPOI-KAREND) 320,435,440
  320 KARPOI=KARPOI+1
  330 IF (LCOMPS(KARTE,KARPOI,1,KDBLNX(1),1)) 340,310,340
  340 IF (LCOMPS(KARTE,KARPOI,1,KDGLZX(1),1)) 390,350,390
  350 IF (ISTUS) 360,370,360
  360 IRC=5
      GO TO 999
  370 IF (ICNT-4) 380,380,180
  380 ICLAR(L3)=ICLAR(L5)
      ICLAR(L5)=KDBLNK
      ISTUS=1
      IPTR=16
      GO TO 30
  390 KDSEMX(1) = KDSEMI
      IF (LCOMPS(KARTE,KARPOI,1,KDSEMX(1),1)) 400,440,400
  400 IF (ISTUS-1) 410,420,999
  410 ISTUS=1
  420 IF (LCOMPS(KARTE,KARPOI,3,KDTOX(1),1)) 450,430,450
  430 KARPOI=KARPOI+3
      ISTUS=2
      IPTR=52
      GO TO 60
  435 KARPOI=KARPOI+1
  440 IF (ISTUS-2) 450,999,999
  450 DO 460 I=1,9
  460 ICLAR(I+12)=ICLAR(I+3)
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2284
      SUBROUTINE DB2284
      DIMENSION LETTER(6)
      COMMON /DC2280/ NTIN,NTDSPL,NTPRT,KARTE(60),KARPOI,KAREND,KDSEMI
      COMMON /DC2280/ IVERFY(20)
      DATA IWRTMX/17/,IWRTM4/68/
       DATA LETTER/1H*,1H2,1H3,1H4,1H5,1H6/,IBLANK/1H /
      KLIM=(KAREND+3)/4
      KA=1
      KE=IWRTMX
      GO TO 20
  10  KE=KE+IWRTMX
  20  IF (KE .GT. KLIM) KE=KLIM
      DO 15 I=KA,KE
  15  CALL CICDC (KARTE(I),1,4)
      WRITE (NTDSPL,30) (KARTE(I),I=KA,KE)
  30  FORMAT (' ',20A4)
      KA=KA+IWRTMX
      IF (KA .LE. KLIM) GO TO 10
      KA=(KARPOI-1)/IWRTM4
      KE=KARPOI-KA*IWRTM4
      KA=KA+1
      WRITE (NTDSPL,40) (IBLANK,I=1,KE),LETTER(KA)
  40  FORMAT (80A1)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD870326--DB2285
      SUBROUTINE DB2285 (ICLAR,IRC)
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2280/ NTIN,NTDSPL,NTPRT,KARTE(60),KARPOI,KAREND,KDSEMI
      COMMON /DC2280/ IVERFY(20)
      DIMENSION LTYPE(21),KTYPE(21),NTYPE(7),NDFLTS(21),ICLAR(*)
       DIMENSION LCHARX(1),KDSEMX(1),LETTX(1),IWRTX(1)
CHP8  DATA LTYPE/'NAME','RFCD','MINR','FORM','TITL','REF','AUT','CELL',
C    1 'SGR','SYM','TYPE','PARM','BETA','BIJ','UIJ','REM','CAS','RVAL',
C    2 'PICT','TEST','ITF'/
Cmw      DATALTYPE/Z'D5C1D4C5',Z'D9C6C3C4',Z'D4C9D5D9',Z'C6D6D9D4',Z'E3C9E3
Cmw     $D3',Z'D9C5C640',Z'C1E4E340',Z'C3C5D3D3',Z'E2C7D940',Z'E2E8D440',Z'
Cmw     $E3E8D7C5',Z'D7C1D9D4',Z'C2C5E3C1',Z'C2C9D140',Z'E4C9D140',Z'D9C5D4
Cmw     $40',Z'C3C1E240',Z'D9E5C1D3',Z'D7C9C3E3',Z'E3C5E2E3',Z'C9E3C640'/
      DATALTYPE/Z'C5D4C1D5',Z'C4C3C6D9',Z'D9D5C9D4',Z'D4D9D6C6',Z'D3E3C9
     $E3',Z'40C6C5D9',Z'40E3E4C1',Z'D3D3C5C3',Z'40D9C7E2',Z'40D4E8E2',Z'
     $C5D7E8E3',Z'D4D9C1D7',Z'C1E3C5C2',Z'40D1C9C2',Z'40D1C9E4',Z'40D4C5
     $D9',Z'40E2C1C3',Z'D3C1E5D9',Z'E3C3C9D7',Z'E3E2C5E3',Z'40C6E3C9'/
CHP8  DATA KTYPE/'N','V','M','F','U','Q','A','E','R','S','T','P','B',
C    1 'C','D','Z','H','I','K','Y','ITF'/
Cmw      DATAKTYPE/Z'D5404040',Z'E5404040',Z'D4404040',Z'C6404040',Z'E44040
Cmw     $40',Z'D8404040',Z'C1404040',Z'C5404040',Z'D9404040',Z'E2404040',Z'
Cmw     $E3404040',Z'D7404040',Z'C2404040',Z'C3404040',Z'C4404040',Z'E94040
Cmw     $40',Z'C8404040',Z'C9404040',Z'D2404040',Z'E8404040',Z'C9E3C640'/
      DATAKTYPE/Z'404040D5',Z'404040E5',Z'404040D4',Z'404040C6',Z'404040
     $E4',Z'404040D8',Z'404040C1',Z'404040C5',Z'404040D9',Z'404040E2',Z'
     $404040E3',Z'404040D7',Z'404040C2',Z'404040C3',Z'404040C4',Z'404040
     $E9',Z'404040C8',Z'404040C9',Z'404040D2',Z'404040E8',Z'40C6E3C9'/
CHP8  DATA NTYPE/'DF','ALL','TF','JRNL','CHCL','SMAT','STAT'/
Cmw      DATANTYPE/Z'C4C64040',Z'C1D3D340',Z'E3C64040',Z'D1D9D5D3',Z'C3C8C3
Cmw     $D3',Z'E2D4C1E3',Z'E2E3C1E3'/
      DATANTYPE/Z'4040C6C4',Z'40D3D3C1',Z'4040C6E3',Z'D3D5D9D1',Z'D3C3C8
     $C3',Z'E3C1D4E2',Z'E3C1E3E2'/
      DATA NDFL/7/,NDFLTS/1,3,4,5,6,7,20,14*0/
CHP8  DATA LCHAR/' -+,'/,LETT/'AZ09'/
Cmw      DATALCHAR/Z'40604E6B'/,LETT/Z'C1E9F0F9'/
      DATALCHAR/Z'6B4E6040'/,LETT/Z'F9F0E9C1'/
CHP8  DATA LCHARX(1)/' -+,'/,LETTX(1)/'AZ09'/
Cmw      DATALCHARX(1)/Z'40604E6B'/,LETTX(1)/Z'C1E9F0F9'/
      DATALCHARX(1)/Z'6B4E6040'/,LETTX(1)/Z'F9F0E9C1'/
CHP8  DATA KDBLNK/'    '/
      DATAKDBLNK/Z'40404040'/
      NCAT=0
      IFLAG(35)=0
      IFLAG(48)=0
      IRC=0
      IUSR=0
      MNSFLG=0
      GO TO 40
   10 MNSFLG=0
   20 IF (KARPOI-KAREND) 30,390,390
   30 KARPOI=KARPOI+1
   40 IF (LCOMPS(KARTE,KARPOI,1,LCHARX(1),1)) 50,20,50
   50 KDSEMX(1) = KDSEMI
      IF (LCOMPS(KARTE,KARPOI,1,KDSEMX(1),1)) 60,390,60
   60 IF (LCOMPS(KARTE,KARPOI,1,LCHARX(1),2)) 80,70,80
   70 MNSFLG=1
      GO TO 20
   80 IF (LCOMPS(KARTE,KARPOI,1,LCHARX(1),3)) 90,10,90
   90 IF (LCOMPS(KARTE,KARPOI,1,LCHARX(1),4)) 100,10,100
  100 KARPOS=KARPOI
      I=1
  110 IF (KARPOI-KAREND) 120,170,170
  120 KARPOI=KARPOI+1
      IF (LCOMPS(KARTE,KARPOI,1,LETTX(1),1)) 140,160,130
  130 IF (LCOMPS(KARTE,KARPOI,1,LETTX(1),2)) 160,160,140
  140 IF (LCOMPS(KARTE,KARPOI,1,LETTX(1),3)) 170,160,150
  150 IF (LCOMPS(KARTE,KARPOI,1,LETTX(1),4)) 160,160,170
  160 I=I+1
      GO TO 110
  170 IF (I-4) 190,190,180
  180 IRC=2
      GO TO 999
  190 IWRT=KDBLNK
      KARPOI=KARPOI-1
      IWRTX(1) = IWRT
      CALL COPYCH (KARTE,KARPOS,I,IWRTX(1),1)
      IWRT = IWRTX(1)
  200 IWRTX(1) = IWRT
      DO 220 I=1,7
      IF (LCOMPS(IWRTX(1),1,4,NTYPE(I),1)) 220,230,220
  220 CONTINUE
      GO TO 340
  230 GO TO (240,270,290,320,321,311,312),I
  240 I=0
      ASSIGN 250 TO NRET
  250 IF (I-NDFL) 260,10,10
  260 I=I+1
      ITMP=NDFLTS(I)
      GO TO 450
  270 ASSIGN 280 TO NRET
      ITMP=0
  280 ITMP=ITMP+1
      IF (ITMP-21) 450,450,10
  290 ASSIGN 300 TO NRET
      ITMP=12
  300 ITMP=ITMP+1
      IF (ITMP-15) 450,450,310
  310 ASSIGN 10 TO NRET
      ITMP=21
      GO TO 450
  311 ASSIGN 10 TO NRET
      IFLAG(43)=1
      IUSR=1
      GO TO 10
  312 ASSIGN 10 TO NRET
      IFLAG(48)=1
      IUSR=1
      GO TO 10
  320 ASSIGN 10 TO NRET
      ITMP=6
      IFLAG(35)=1
      IF (MNSFLG) 330,450,330
  330 IFLAG(35)=0
      GO TO 450
  321 ASSIGN 10 TO NRET
      ITMP=11
      GO TO 450
  340 ASSIGN 10 TO NRET
      ITMP=1
  350 IF (IWRT .EQ. LTYPE(ITMP)) GO TO 450
  360 IF (IWRT .EQ. KTYPE(ITMP)) GO TO 450
  370 ITMP=ITMP+1
      IF (ITMP-21) 350,350,380
  380 IRC=7
      GO TO 999
  390 IF (IUSR) 440,400,440
  400 IF (NDFL) 430,430,410
  410 DO 420 I=1,NDFL
  420 ICLAR(I+1)=NDFLTS(I)
  430 NCAT=NDFL
  440 ICLAR(1)=NCAT
      GO TO 999
  450 IUSR=1
      IF (NCAT) 480,480,460
  460 DO 470 II=1,NCAT
      IF (ICLAR(II+1)-ITMP) 470,490,470
  470 CONTINUE
  480 IF (MNSFLG) 540,530,540
  490 IF (MNSFLG) 510,540,510
  500 II=II+1
      ICLAR(II)=ICLAR(II+1)
  510 IF (II-NCAT) 500,520,520
  520 NCAT=NCAT-1
      GO TO 540
  530 NCAT=NCAT+1
      ICLAR(NCAT+1)=ITMP
  540 GO TO NRET,(10,250,280,300)
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD860108--DB2286
      SUBROUTINE DB2286 (KARTE,KARPOI,KAREND,IZAHL,IRC)
      DIMENSION KARTE(*)
       INTEGER KDSEMX(1)
CHP8  DATA KDSEMI/';'/
Cmw      DATAKDSEMI/Z'5E404040'/
      DATAKDSEMI/Z'4040405E'/
CHP8  DATA KDSEMX(1)/';'/
Cmw      DATAKDSEMX(1)/Z'5E404040'/
      DATAKDSEMX(1)/Z'4040405E'/
      IRC=0
      KARPOI=KARPOI-1
      IVORZ=0
      IAC=0
  10  IF (KARPOI-KAREND) 20,50,50
  20  KARPOI=KARPOI+1
      CALL CONVCI (KARTE,KARPOI,IZ)
      IF (IZ+1) 30,10,70
  30  IF (IZ+3) 40,80,60
  40  IF (LCOMPS(KARTE,KARPOI,1,KDSEMX(1),1)) 60,50,60
  50  IRC=1
      GO TO 999
  60  IRC=2
      GO TO 999
  80  IVORZ=-1
      GO TO 90
  70  IVORZ=1
 110  IAC=IAC*10+IZ
  90  KARPOI=KARPOI+1
      CALL CONVCI (KARTE,KARPOI,IZ)
      IF (IZ) 120,110,110
 120  IF (IVORZ) 130,60,140
 130  IAC=-IAC
 140  IZAHL=IAC
 999  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860108--DB2287
      SUBROUTINE DB2287 (KARTE,KARPOI,KAREND,IZAHL,IRC)
      DIMENSION KARTE(*)
       DIMENSION IVGLZX(1)
CHP8  DATA IVGLZ/' *09'/
Cmw      DATAIVGLZ/Z'405CF0F9'/
      DATAIVGLZ/Z'F9F05C40'/
CHP8  DATA IVGLZX(1)/' *09'/
Cmw      DATAIVGLZX(1)/Z'405CF0F9'/
      DATAIVGLZX(1)/Z'F9F05C40'/
      IRC=1
      GO TO 25
  10  IF (KARPOI-KAREND) 20,80,80
  20  KARPOI=KARPOI+1
  25  IF (LCOMPS(KARTE,KARPOI,1,IVGLZX(1),1)) 30,10,30
  30  IF (LCOMPS(KARTE,KARPOI,1,IVGLZX(1),2)) 50,40,50
  40  KARPOI=KARPOI+1
      IZAHL=0
      GO TO 999
  50  IF (LCOMPS(KARTE,KARPOI,1,IVGLZX(1),3)) 80,70,60
  60  IF (LCOMPS(KARTE,KARPOI,1,IVGLZX(1),4)) 70,70,80
  70  CALL DB2286 (KARTE,KARPOI,KAREND,IZAHL,NRC)
      IRC=0
      GO TO 999
  80  IRC=2
      IZAHL=-1
 999  RETURN
      END
C ----------------------------------------OWNUNC411----UPD850814--DB2288
      SUBROUTINE DB2288 (KARTE,KARPOI,KAREND,ITAB,NRPOS)
      DIMENSION KARTE(*),ITAB(*),KDDELM(2)
CHP8  DATA KDDELM/' ;!,','=*  '/
Cmw      DATAKDDELM/Z'405E5A6B',Z'7E5C4040'/
      DATAKDDELM/Z'6B5A5E40',Z'40405C7E'/
      GO TO 20
   10 KARPOI=KARPOI+1
   20 IF (KARPOI-KAREND) 30,150,150
   30 IF (LCOMPS(KARTE,KARPOI,1,KDDELM,1)) 40,10,40
   40 IF (LCOMPS(KARTE,KARPOI,1,KDDELM,2)) 50,150,50
   50 DO 60 I=3,6
      IF (LCOMPS(KARTE,KARPOI,1,KDDELM,I)) 60,160,60
   60 CONTINUE
   70 ISTART=KARPOI
      GO TO 100
   80 DO 90 I=1,7
      IF (LCOMPS(KARTE,KARPOI,1,KDDELM,I)) 90,110,90
   90 CONTINUE
  100 KARPOI=KARPOI+1
      IF (KARPOI-KAREND) 80,110,110
  110 LEN=KARPOI-ISTART
      NR=0
      J=0
  120 NR=NR+1
      J=J+1
      IF (LCOMPS(KARTE,ISTART,LEN,ITAB,J)) 130,170,130
  130 J=J+1
      IF (LCOMPS(ITAB,J,1,KDDELM,2)) 140,120,140
  140 IF (LCOMPS(ITAB,J,1,KDDELM,3)) 130,160,130
  150 NR=-1
      GO TO 170
  160 NR=0
      KARPOI=ISTART
  170 NRPOS=NR
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD850814--DB2289
      SUBROUTINE DB2289 (KARTE,KARPOI,KAREND,ICLAR,ICHRMX,IRC)
      DIMENSION KARTE(*),ICLAR(*)
       DIMENSION KDB(1),KDA(1),KDS(1)
CHP8  DATA KDBLNK/'    '/,KDAPO /''''/,KDSEMI/';'/
Cmw      DATAKDBLNK/Z'40404040'/,KDAPO/Z'7D404040'/,KDSEMI/Z'5E404040'/
      DATAKDBLNK/Z'40404040'/,KDAPO/Z'4040407D'/,KDSEMI/Z'4040405E'/
CHP8  DATA KDB(1)/'    '/,KDA(1)/''''/,KDS(1)/';'/
Cmw      DATAKDB(1)/Z'40404040'/,KDA(1)/Z'7D404040'/,KDS(1)/Z'5E404040'/
      DATAKDB(1)/Z'40404040'/,KDA(1)/Z'4040407D'/,KDS(1)/Z'4040405E'/
      IRC=0
      NRCHR=0
      IM=(ICHRMX+7)/4
      DO 10 I=2,IM
   10 ICLAR(I)=KDBLNK
      GO TO 40
   20 IF (KARPOI-KAREND) 30,180,180
   30 KARPOI=KARPOI+1
   40 IF (LCOMPS(KARTE,KARPOI,1,KDB(1),1)) 50,20,50
   50 IF (LCOMPS(KARTE,KARPOI,1,KDA(1),1)) 70,150,70
   60 KARPOI=KARPOI+1
      IF (LCOMPS(KARTE,KARPOI,1,KDB(1),1)) 70,180,70
   70 IF (LCOMPS(KARTE,KARPOI,1,KDS(1),1)) 80,180,80
   80 IF (NRCHR-ICHRMX) 90,170,170
   90 NRCHR=NRCHR+1
      CALL COPYCH (KARTE,KARPOI,1,ICLAR,NRCHR+4)
      IF (KARPOI-KAREND) 60,180,180
  100 KARPOI=KARPOI+1
      IF (LCOMPS(KARTE,KARPOI,1,KDA(1),1)) 130,110,130
  110 IF (KARPOI-KAREND) 120,180,180
  120 KARPOI=KARPOI+1
      IF (LCOMPS(KARTE,KARPOI,1,KDA(1),1)) 180,130,180
  130 IF (NRCHR-ICHRMX) 140,170,170
  140 NRCHR=NRCHR+1
      CALL COPYCH (KARTE,KARPOI,1,ICLAR,NRCHR+4)
  150 IF (KARPOI-KAREND) 100,160,160
  160 IRC=4
      GO TO 180
  170 IRC=2
  180 ICLAR(1)=NRCHR
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD880229--DB2290
                SUBROUTINE DB2290 (ZELLE,ZELVOL,NBGTYP)
      DIMENSION ZELLE(6),IBGTAB(2,8),BGTRTB(3,8)
      COMMON /DC2290/ DG(3,3),RG(3,3),RK(3),BGTR(3,4),NBGT
      DATA BOG/1.745329E-2/,IBGTAB/3,1, 1,1, 1,2, 1,3, 1,4, 2,5, 2,7,
     1 2,7/
      DATA BGTRTB/0.,.5,.5, .5,0.,.5, .5,.5,0., .5,.5,.5,
     1 .3333333,.6666667,.6666667, .6666667,.3333333,.3333333,
     2 .3333333,.6666667,.3333333, .6666667,.3333333,.6666667/
      DO 10 I=1,3
      IF (ZELLE(I)) 990,990,1
    1 TEMP=ZELLE(I+3)
      IF (TEMP-8.0) 990,2,2
    2 IF (TEMP-172.) 3,3,990
    3 DO 10 J=1,3
      DG(I,J)=0.
   10 RG(I,J)=0.
      DG(1,1)=ZELLE(1)
      DG(1,2)=ZELLE(2)*COS(ZELLE(6)*BOG)
      TEMP=ZELLE(2)*ZELLE(2)-DG(1,2)*DG(1,2)
      IF (TEMP) 990,990,17
   17 DG(2,2)=SQRT(TEMP)
      DG(1,3)=ZELLE(3)*COS(ZELLE(5)*BOG)
      DG(2,3)=(ZELLE(2)*ZELLE(3)*COS(ZELLE(4)*BOG)-DG(1,2)*DG(1,3))
     1 / DG(2,2)
      TEMP=ZELLE(3)*ZELLE(3)-DG(1,3)*DG(1,3)-DG(2,3)*DG(2,3)
      IF (TEMP) 990,990,18
   18 DG(3,3)=SQRT(TEMP)
      ZELVOL=DG(1,1)*DG(2,2)*DG(3,3)
      RG(1,1)=1./DG(1,1)
      RG(2,2)=1./DG(2,2)
      RG(3,3)=1./DG(3,3)
      RG(2,1)=-DG(1,2)/(DG(2,2)*DG(1,1))
      RG(3,2)=-DG(2,3)/(DG(2,2)*DG(3,3))
      RG(3,1)=(DG(1,2)*DG(2,3)/DG(2,2)-DG(1,3))/(DG(1,1)*DG(3,3))
      DO 30 I=1,3
      TEMP=0.
      DO 20 J=1,3
      TEMP=TEMP+RG(J,I)*RG(J,I)
   20 CONTINUE
      RK(I)=SQRT(TEMP)
   30 CONTINUE
      NBGT=1
      BGTR(1,1)=0.
      BGTR(2,1)=0.
      BGTR(3,1)=0.
      IF (NBGTYP) 999,999,40
   40 IF (NBGTYP-9) 50,999,999
   50 J=IBGTAB(1,NBGTYP)
      K=IBGTAB(2,NBGTYP)
      DO 70 I=1,J
      NBGT=NBGT+1
      DO 60 L=1,3
   60 BGTR(L,NBGT)=BGTRTB(L,K)
   70 K=K+1
      GO TO 999
  990 ZELVOL=0.
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880229--DB2291
          SUBROUTINE DB2291 (AT,SYM,NSYM,ITOMS,ATOMS,NCDDM,
     1          ICODE,IZ1,IZ2,DMN,DMX,IOPT,NCD,IRC)
      COMMON /DC2290/ DG(3,3),RG(3,3),RK(3),BGTR(3,4),NBGT
      DIMENSION XEBOX(3),ICTAB(5),ICD(6),XZENTR(3),X1(3),X2(3)
      DIMENSION X3(3),XO(3),XU(3),XTRIK(3),IT1(3),IT2(3),XSTRT(3)
      DIMENSION AT(3,*),SYM(12,*),ATOMS(7,*),XAKT(3)
      DIMENSION ITOMS(2,*)
      DATA ICTAB/10,100,10,10,10/
      IRC=0
      DO 10 I=1,3
   10 XEBOX(I)=DMX*RK(I)
      DQ=DMX*DMX
      DQN=DMN*DMN
      ITOMS(2,1)=0
      IF (ICODE-1000000) 20,50,50
   20 DO 40 I=1,3
      TEMP=AT(I,ICODE)
      IF (ABS(TEMP)-2.) 40,30,30
   30 IRC=8
      GO TO 999
   40 XZENTR(I)=TEMP
      ITOMS(1,1)=ICODE*1000000+555011
      GO TO 80
   50 J=ICODE
      ITOMS(1,1)=J
      DO 60 I=1,5
      K=J
      J=J/ICTAB(I)
   60 ICD(7-I)=K-J*ICTAB(I)
      ICD(1)=J
      IANR=J
      ISYNR=ICD(5)
      IBGTNR=ICD(6)
      J=-3
      DO 70 I=1,3
      J=J+4
      XZENTR(I)=SYM(J,ISYNR)+BGTR(I,IBGTNR)+FLOAT(ICD(I+1)-5)
     1 +SYM(J+1,ISYNR)*AT(1,IANR)+SYM(J+2,ISYNR)*AT(2,IANR)
     2 +SYM(J+3,ISYNR)*AT(3,IANR)
   70 CONTINUE
   80 X2(1)=DG(1,1)*XZENTR(1)+DG(1,2)*XZENTR(2)+DG(1,3)*XZENTR(3)
      X2(2)=                  DG(2,2)*XZENTR(2)+DG(2,3)*XZENTR(3)
      X2(3)=                                    DG(3,3)*XZENTR(3)
      NCD=1
      DO 90 I=1,3
      ATOMS(I+1,1)=XZENTR(I)
   90 ATOMS(I+4,1)=X2(I)
      ATOMS(1,1)=0.
      DO 100 I=1,3
      XU(I)=XZENTR(I)-XEBOX(I)-.00001
  100 XO(I)=XZENTR(I)+XEBOX(I)+.00001
      DO 480 IANR=IZ1,IZ2
      DO 130 I=1,3
      TEMP=AT(I,IANR)
      IF (ABS(TEMP)-2.) 120,110,110
  110 IRC=4
      GO TO 480
  120 XTRIK(I)=TEMP
  130 CONTINUE
      NCDBG=NCD
      DO 470 ISYNR=1,NSYM
      J=-3
      DO 140 I=1,3
      J=J+4
      X1(I)=SYM(J+1,ISYNR)*XTRIK(1)+SYM(J+2,ISYNR)*XTRIK(2)
     1    +SYM(J+3,ISYNR)*XTRIK(3)+SYM(J,ISYNR)
  140 CONTINUE
      DO 460 IBGTNR=1,NBGT
      DO 150 I=1,3
  150 XAKT(I)=X1(I)+BGTR(I,IBGTNR)
      DO 270 I=1,3
      J=5
      TEMP=XAKT(I)
      GO TO 170
  160 TEMP=TEMP-1.
      J=J-1
  170 IF (TEMP-1.-XU(I)) 190,160,160
  180 TEMP=TEMP+1.
      J=J+1
  190 IF (TEMP-XU(I)) 180,200,200
  200 K=J
      XSTRT(I)=TEMP
      GO TO 220
  210 TEMP=TEMP+1.
      K=K+1
  220 IF (TEMP+1.-XO(I)) 210,210,240
  230 TEMP=TEMP-1.
      K=K-1
  240 IF (TEMP-XO(I)) 250,250,230
  250 IF (K-J) 460,260,260
  260 IT1(I)=J
      IT2(I)=K
  270 CONTINUE
      XAKT(1)=XSTRT(1)
      I=IT1(1)
  280 XAKT(2)=XSTRT(2)
      J=IT1(2)
  290 XAKT(3)=XSTRT(3)
      K=IT1(3)
  300 X3(1)=DG(1,1)*XAKT(1)+DG(1,2)*XAKT(2)+DG(1,3)*XAKT(3)
      X3(2)=                DG(2,2)*XAKT(2)+DG(2,3)*XAKT(3)
      X3(3)=                                DG(3,3)*XAKT(3)
      T1=0.
      DO 310 L=1,3
      TEMP=X2(L)-X3(L)
  310 T1=TEMP*TEMP+T1
      IF (T1-DQ) 320,320,430
  320 IF (T1-DQN) 430,330,330
  330 IF (IOPT) 390,350,340
  340 NCDBG=0
  350 M=NCDBG
      GO TO 380
  360 M=M+1
      DO 370 L=1,3
      IF (ABS(ATOMS(L+1,M)-XAKT(L))-.0003) 370,370,380
  370 CONTINUE
      ITOMS(2,M)=ITOMS(2,M)+1
      GO TO 430
  380 IF (M-NCD) 360,390,390
  390 IF (NCD-NCDDM) 410,400,400
  400 IRC=16
      GO TO 999
  410 NCD=NCD+1
      ITOMS(1,NCD)=((((IANR*10+I)*10+J)*10+K)*100+ISYNR)*10+IBGTNR
      ITOMS(2,NCD)=1
      ATOMS(1,NCD)=SQRT(T1)
      DO 420 L=1,3
      ATOMS(L+1,NCD)=XAKT(L)
  420 ATOMS(L+4,NCD)=X3(L)
  430 XAKT(3)=XAKT(3)+1.
      K=K+1
      IF (K-IT2(3)) 300,300,440
  440 XAKT(2)=XAKT(2)+1.
      J=J+1
      IF (J-IT2(2)) 290,290,450
  450 XAKT(1)=XAKT(1)+1.
      I=I+1
      IF (I-IT2(1)) 280,280,460
  460 CONTINUE
  470 CONTINUE
  480 CONTINUE
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880229--DB2292
                          SUBROUTINE DB2292
     1    (MNAR,NBRAS,IHMSYM,NTYP,SYM,NSYM,NSYMDM,NBGTYP,IRC)
      DIMENSION MNAR(*),IHMSYM(3),SYM(12,*),ID2(3),ISTK(4)
      DIMENSION NBRAS(*),VKT(3)
      DATA ITABIN/0/,IVIER/4/,I2H30/1073741824/,I2H3C/1006632960/
CHP8  DATA ID2/2,3,1/,ISTKDM/4/,I2H38/939524096/,IBUMZF/'-09 '/
Cmw      DATAID2/2,3,1/,ISTKDM/4/,I2H38/939524096/,IBUMZF/Z'60F0F940'/
      DATAID2/2,3,1/,ISTKDM/4/,I2H38/939524096/,IBUMZF/Z'40F9F060'/
      IRC=0
      IF (NTYP) 700,10,10
   10 IF (ITABIN) 80,20,80
   20 CALL DB2313 (8,1,MNAR,NBRAS,IMADR,MEML,IRC)
      IF (IRC) 990,40,30
   30 IRC=4
      GO TO 990
   40 CALL CHRINT(MNAR(IMADR),1,4,IHMSDM)
      CALL CHRINT(MNAR(IMADR+1),1,4,ISYMDM)
      IHMSD4=IHMSDM*4
      IF ((IHMSD4+ISYMDM+3)*4 .EQ. MEML) GO TO 50
      IRC=5
      GO TO 990
   50 J=IMADR+3
      IADHMS=(J/IVIER)*4
      IADSYM=IMADR+IHMSD4+3
      I=IADHMS
      IF (I .EQ. J) GO TO 70
      DO 60 K=1,IHMSD4
      MNAR(I)=MNAR(J)
      I=I+1
      J=J+1
   60 CONTINUE
   70 ITABIN=1
   80 NBGTYP=0
      NSYM=1
      DO 90 I=1,12
   90 SYM(I,1)=0.
      SYM(2,1)=1.
      SYM(7,1)=1.
      SYM(12,1)=1.
      IDURCH=0
      IF (NTYP) 120,120,200
  100 IF (LCOMPS(IHMSYM,I+1,1, IBUMZF,2)) 190,110,110
  110 CALL COPYCH (IHMSYM,I+1,1, IHMSYM,I)
      CALL COPYCH (IBUMZF,1,1, IHMSYM,I+1)
      IDURCH=1
  120 M1=IADHMS
      M2=IADHMS+IHMSD4-4
  130 M=((M1+M2)/8)*IVIER
      IF (LCOMPS(IHMSYM,1,8,MNAR(M),1)) 140,230,150
  140 M2=M-4
      GO TO 160
  150 M1=M+4
  160 IF (M1 .LE. M2) GO TO 130
      IF (IDURCH) 190,170,190
  170 DO 180 I=1,7
      IF (LCOMPS(IHMSYM,I,1, IBUMZF,1)) 180,100,180
  180 CONTINUE
  190 IRC=2
      GO TO 990
  200 J=IADHMS+2
      DO 210 I=1,IHMSDM
      CALL CHRINT (MNAR(J),1,4, JJ)
      IF (IHMSYM(3) .EQ. JJ) GO TO 220
      J=J+4
  210 CONTINUE
      IRC=1
      GO TO 990
  220 M=J-2
      IHMSYM(1)=MNAR(M)
      IHMSYM(2)=MNAR(M+1)
  230 CALL CHRINT(MNAR(M+2),1,4,IHMSYM(3))
      CALL CHRINT(MNAR(M+3),1,4,IPOI)
      IPOI = IPOI + IADSYM
      ISTKPO=0
  240 LASTSM=0
  250 CALL CHRINT(MNAR(IPOI),1,4,IW)
      IPOI=IPOI+1
      IF (IW .LT. I2H30) GO TO 260
      LASTSM=1
      IW=IW-I2H30
  260 IF (IW .LT. 32) GO TO 610
      IF (IW .GT. I2H3C) GO TO 580
      IF (IW .GT. I2H38) GO TO 720
      IF (NSYM-NSYMDM) 280,270,270
  270 IRC=6
      GO TO 999
  280 NSYM=NSYM+1
      N=12
      DO 300 I=1,3
      DO 290 J=1,3
      IWR=IW
      IW=IW/4
      SYM(N,NSYM)=IWR-4*IW-2
      N=N-1
  290 CONTINUE
      IWR=IW
      IW=IW/16
      SYM(N,NSYM)=FLOAT(IWR-16*IW)/12.
      N=N-1
  300 CONTINUE
  310 IF (LASTSM) 320,250,320
  320 IF (ISTKPO) 999,999,330
  330 IPOI=ISTK(ISTKPO)
      ISTKPO=ISTKPO-1
      GO TO 240
  340 DO 370 J=2,3
      DO 370 I=1,IEND
      IF (NSYM-NSYMDM) 350,270,270
  350 NSYM=NSYM+1
      K=ID2(J)
      L=ID2(K)
      J1=(J-1)*4
      K1=(K-1)*4
      L1=(L-1)*4
      DO 360 M=1,4
      SYM(M,NSYM)=SYM(J1+M,I)
      SYM(M+4,NSYM)=SYM(K1+M,I)
  360 SYM(M+8,NSYM)=SYM(L1+M,I)
  370 CONTINUE
      GO TO 310
  380 DO 430 I=1,IEND
      IF (NSYM-NSYMDM) 390,270,270
  390 NSYM=NSYM+1
      DO 400 M=1,12
  400 SYM(M,NSYM)=-SYM(M,I)
      DO 420 J=1,9,4
      IF (SYM(J,NSYM)) 410,420,420
  410 SYM(J,NSYM)=SYM(J,NSYM)+1.
  420 CONTINUE
  430 CONTINUE
      GO TO 310
  440 IEND=NSYM-1
      I=NSYM
      IF (IEND-1) 450,450,460
  450 IRC=7
      GO TO 999
  460 DO 570 J=2,IEND
      IF (NSYM-NSYMDM) 470,270,270
  470 NSYM=NSYM+1
      DO 480 K=1,12
  480 SYM(K,NSYM)=0.
      LA=-3
      DO 560 L=1,3
      LA=LA+4
      MA=-4
      DO 500 M=1,3
      MA=MA+4
      TEMP=SYM(LA+M,I)
      DO 490 K=1,4
      KA=LA+K-1
  490 SYM(KA,NSYM)=SYM(KA,NSYM)+TEMP*SYM(MA+K,J)
  500 CONTINUE
      TEMP=SYM(LA,NSYM)+SYM(LA,I)
      GO TO 520
  510 TEMP=TEMP-1.
  520 IF (TEMP-.95) 540,540,510
  530 TEMP=TEMP+1.
  540 IF (TEMP+.08) 530,530,550
  550 SYM(LA,NSYM)=TEMP
  560 CONTINUE
  570 CONTINUE
      GO TO 310
  580 IF (ISTKPO-ISTKDM) 600,590,590
  590 IRC=8
      GO TO 999
  600 ISTKPO=ISTKPO+1
      ISTK(ISTKPO)=IPOI
      IPOI=IW-I2H3C+IADSYM
      GO TO 250
  610 IF (IW-14) 630,620,640
  620 NBGTYP=8
      GO TO 310
  630 IF (IW-10) 650,650,640
  640 IRC=3
      GO TO 990
  650 IEND=NSYM
      IF (IW-1) 310,310,660
  660 IF (IW-7) 670,340,680
  670 NBGTYP=IW-1
      GO TO 310
  680 IF (IW-9) 380,690,440
  690 NBGTYP=6
      GO TO 310
  700 IF (ITABIN) 710,990,710
  710 CALL DB2219(2292,640)
      CALL DB2232 (MNAR,IMADR,IRC)
      ITABIN=0
      GO TO 999
  720 IW=IW-I2H38
      DO 730 I=1,3
      IWR=IW
      IW=IW/32
      VKT(I)=FLOAT(IWR-32*IW)/24.
  730 CONTINUE
      DO 800 K=1,NSYM
      J=1
      DO 790 I=1,3
      TEMP=SYM(J,K)-VKT(I)+SYM(J+1,K)*VKT(1)+SYM(J+2,K)*VKT(2)
     1                    +SYM(J+3,K)*VKT(3)
      GO TO 750
  740 TEMP=TEMP-1.
  750 IF (TEMP-.95) 770,770,740
  760 TEMP=TEMP+1.
  770 IF (TEMP+.08) 760,760,780
  780 SYM(J,K)=TEMP
      J=J+4
  790 CONTINUE
  800 CONTINUE
      GO TO 310
  990 NSYM=0
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880229--DB2293
                SUBROUTINE DB2293 (BUF,LSTR,LEN,IRC)
      DIMENSION BUF(*),ITAB(6),ITRANS(11),IFLG(4),LSTR(*)
CHP8  DATA ITAB/'0123','4567','89,+','- $/','XYZx','yz  '/
Cmw      DATAITAB/Z'F0F1F2F3',Z'F4F5F6F7',Z'F8F96B4E',Z'60405B61',Z'E7E8E9A
Cmw     $7',Z'A8A94040'/
      DATAITAB/Z'F3F2F1F0',Z'F7F6F5F4',Z'4E6BF9F8',Z'615B4060',Z'A7E9E8E
     $7',Z'4040A9A8'/
      DATA ITRANS/112,16,14,13,512,12,712,23,34,56,1112/
      LENG=LEN+1
      DO 10 I=1,12
   10 BUF(I)=0.
      IRC=0
      LINC=0
      IWDH=0
      LPOI=0
   20 DO 30 I=1,4
   30 IFLG(I)=0
   40 ITYP=0
      IVORZ=0
      IZFF=0
      KBUF=0
   50 IF (IWDH) 60,70,60
   60 IWDH=0
      GO TO 80
   70 LPOI=LPOI+1
   80 IF (LPOI-LENG) 90,160,410
   90 DO 100 IZCH=1,22
      IF (LCOMPS(LSTR,LPOI,1, ITAB,IZCH)) 100,110,100
  100 CONTINUE
      IRC=5
      GO TO 999
  110 IF (IZCH-10) 120,120,150
  120 IF (IVORZ) 140,130,140
  130 IVORZ=1
  140 IZFF=1
      KBUF=KBUF*10+IZCH-1
      GO TO 50
  150 IGO=IZCH-10
      GO TO (160,270,270,50,160,320,340,340,340,330,330,330),IGO
  160 IF (ITYP) 170,170,200
  170 IF (IVORZ) 180,190,180
  180 IRC=1
      GO TO 999
  190 LINC=LINC+4
      IF (LINC-8) 20,20,999
  200 IF (IFLG(1)) 210,220,210
  210 IRC=6
      GO TO 999
  220 IFLG(1)=1
      IF (IVORZ) 230,230,240
  230 IRC=7
      GO TO 999
  240 IWDH=1
      DO 250 I=1,11
      IF (KBUF-ITRANS(I)) 250,260,250
  250 CONTINUE
      IRC=3
      GO TO 999
  260 BUF(LINC+1)=FLOAT(I)/12.
      GO TO 40
  270 IF (IVORZ) 280,300,280
  280 IF (ITYP) 290,290,200
  290 IRC=8
  300 IVORZ=1
      IF (IGO-3) 50,310,50
  310 IVORZ=-1
      GO TO 50
  320 ITYP=1
      GO TO 50
  330 IGO=IGO-3
  340 IF (ITYP) 350,350,200
  350 ITYP=IGO-5
      IF (IFLG(ITYP)) 210,360,210
  360 IFLG(ITYP)=1
      IF (IVORZ) 380,370,380
  370 IVORZ=1
  380 IF (IZFF) 390,390,400
  390 KBUF=1
  400 BUF(LINC+ITYP)=FLOAT(KBUF*IVORZ)
      GO TO 40
  410 IRC=9
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2294
      SUBROUTINE DB2294 (KARTE,KARPOI,KAREND,ICLAR,IRC)
      DIMENSION KARTE(*),KEYWD(18),IPARAM(12),IELEM(12)
      DIMENSION ICLAR(*),IDELIM(2),ZAHL(3),IZAHL(3),LIST(7)
      DIMENSION ICLAC(2)
      COMMON /DC2201/ IFLAG(50)
      EQUIVALENCE (ZAHL(1),IZAHL(1))
CHP8  DATA IELEM/'D','F','FR','I','IR','T','S','SE','C','CO','ALL',
C    1 '    '/
Cmw      DATAIELEM/Z'C4404040',Z'C6404040',Z'C6D94040',Z'C9404040',Z'C9D940
Cmw     $40',Z'E3404040',Z'E2404040',Z'E2C54040',Z'C3404040',Z'C3D64040',Z'
Cmw     $C1D3D340',Z'40404040'/
      DATAIELEM/Z'404040C4',Z'404040C6',Z'4040D9C6',Z'404040C9',Z'4040D9
     $C9',Z'404040E3',Z'404040E2',Z'4040C5E2',Z'404040C3',Z'4040D6C3',Z'
     $40D3D3C1',Z'40404040'/
CHP8  DATA KEYWD/'D;F;','FR;I',';IR;','T;S;','SE;C',';CO;','AN;A',
C    1 'ND;A','NGLE','S;FR','OM;T','O;DM','AX;D','MIN;','SELE','CT;C',
C    2 'OORD','!'/
Cmw      DATAKEYWD/Z'C45EC65E',Z'C6D95EC9',Z'5EC9D95E',Z'E35EE25E',Z'E2C55E
Cmw     $C3',Z'5EC3D65E',Z'C1D55EC1',Z'D5C45EC1',Z'D5C7D3C5',Z'E25EC6D9',Z'
Cmw     $D6D45EE3',Z'D65EC4D4',Z'C1E75EC4',Z'D4C9D55E',Z'E2C5D3C5',Z'C3E35E
Cmw     $C3',Z'D6D6D9C4',Z'5A404040'/
      DATAKEYWD/Z'5EC65EC4',Z'C95ED9C6',Z'5ED9C95E',Z'5EE25EE3',Z'C35EC5
     $E2',Z'5ED6C35E',Z'C15ED5C1',Z'C15EC4D5',Z'C5D3C7D5',Z'D9C65EE2',Z'
     $E35ED4D6',Z'D4C45ED6',Z'C45EE7C1',Z'5ED5C9D4',Z'C5D3C5E2',Z'C35EE3
     $C3',Z'C4D9D6D6',Z'4040405A'/
CHP8  DATA KDBLNK/'    '/,LBUAZ/'AZ'/,ICLDIM/30/
Cmw      DATAKDBLNK/Z'40404040'/,LBUAZ/Z'C1E94040'/,ICLDIM/30/
      DATAKDBLNK/Z'40404040'/,LBUAZ/Z'4040E9C1'/,ICLDIM/30/
CHP8  DATA IDELIM/' ,;=','*'/,IZIFF/'09.'/,ZAHL/.01,-1.2,0./
Cmw      DATAIDELIM/Z'406B5E7E',Z'5C404040'/,IZIFF/Z'F0F94B40'/,ZAHL/.01,-1
Cmw     $.2,0./
      DATAIDELIM/Z'7E5E6B40',Z'4040405C'/,IZIFF/Z'404BF9F0'/,ZAHL/.01,-1
     $.2,0./
      DATA L1/1/,L2/2/,L3/3/,L4/4/,L5/5/,L6/6/,L7/7/,L8/8/,L9/9/
      DATA L10/10/,L11/11/,L12/12/,L13/13/,L14/14/
      IRC=0
      NTDSPL=IFLAG(16)
      ICLAR(L1)=6
      ICLAR(L2)=1
      ICLAR(L3)=-1
      DO 10 I=4,7
   10 ICLAR(I)=14
      ICLAR(L14)=IELEM(11)
      ICLAR(L8)=IZAHL(1)
      ICLAR(L9)=IZAHL(2)
      ICLAR(L10)=0
      ICLAR(L11)=0
      ICLAR(L12)=1
      ICLAR(L13)=999
      ICLPOI=14
   20 KARPOS=KARPOI
      CALL DB2288 (KARTE,KARPOI,KAREND,KEYWD,NRPOS)
   30 IF (NRPOS) 640,40,60
   40 CALL DB2289 (KARTE,KARPOS,KAREND,LIST,8,IRC)
      CALL CICDCS (LIST(2),1,4,ICLAC)
      WRITE (NTDSPL,50) ICLAC
   50 FORMAT (' Unkonwn keyword: ',2A4)
      GO TO 990
   60 GO TO (70,70,70,70,70,70,70,70,70,70,70,20,90,100,110,370,360,350,
     1  560),NRPOS
   70 CALL DB2289 (KARTE,KARPOS,KAREND,LIST,8,IRC)
      CALL CICDCS (LIST(2),1,4,ICLAC)
      WRITE (NTDSPL,80) ICLAC
   80 FORMAT (' Keyword ambiguous: ',2A4)
      GO TO 990
   90 ICLAR(L2)=2
      GO TO 20
  100 IFTPOI=4
      GO TO 120
  110 IFTPOI=6
  120 IF (ICLAR(IFTPOI)-14) 130,150,130
  130 IRC=112
      GO TO 999
  140 IRC=114
      GO TO 999
  150 ICLAR(IFTPOI)=ICLPOI+1
      ICLAR(IFTPOI+1)=ICLPOI
  160 KARPOS=KARPOI
      CALL DB2288 (KARTE,KARPOI,KAREND,KEYWD,NRPOS)
      IF (NRPOS) 640,260,170
  170 IF (NRPOS-11) 190,70,180
  180 IF (NRPOS-13) 210,60,60
  190 IF (ICLPOI-ICLDIM) 200,140,140
  200 ICLPOI=ICLPOI+1
      ICLAR(IFTPOI+1)=ICLAR(IFTPOI+1)+1
      ICLAR(ICLPOI)=IELEM(NRPOS)
      GO TO 250
  210 IF (LCOMPS(KARTE,KARPOI,1,IDELIM,1)) 220,240,220
  220 IF (LCOMPS(KARTE,KARPOI,1,IDELIM,2)) 230,240,230
  230 IF (LCOMPS(KARTE,KARPOI,1,IDELIM,3)) 235,640,235
  235 IF (LCOMPS(KARTE,KARPOI,1,IDELIM,4)) 160,236,160
  236 IRC=116
      GO TO 999
  240 KARPOI=KARPOI+1
  250 IF (KARPOI-KAREND) 210,640,640
  260 I=KARPOI
      KARPOI=KARPOI+1
      IF (LCOMPS(KARTE,I,3,IELEM(11),1)) 280,270,280
  270 NRPOS=11
      KARPOI=KARPOI+2
      GO TO 190
  280 IF (LCOMPS(KARTE,KARPOI,1,LBUAZ,1)) 310,300,290
  290 IF (LCOMPS(KARTE,KARPOI,1,LBUAZ,2)) 300,300,310
  300 KARPOI=KARPOI+1
  310 NRPOS=12
      IELEM(NRPOS)=KDBLNK
      CALL COPYCH(KARTE,I,KARPOI-I,IELEM(NRPOS),1)
      CALL DB2012 (IELEM(NRPOS),LEN,LIST)
      IF (LIST(1)) 330,330,320
  320 IF (LIST(1)-130) 190,330,330
  330 CONTINUE
      CALL CICDCS (IELEM(NRPOS),1,4,ICLAC)
      WRITE (NTDSPL,340) ICLAC(1)
  340 FORMAT (' Element ''',A4,''' not found or misspelled keyword.')
      GO TO 990
  350 ICLAR(L10)=1
      GO TO 20
  360 ICLPOS=8
      GO TO 380
  370 ICLPOS=9
  380 IF (KARPOI-KAREND) 390,450,450
  390 KARPOI=KARPOI+1
      IF (LCOMPS(KARTE,KARPOI,1,IDELIM,1)) 400,380,400
  400 IF (LCOMPS(KARTE,KARPOI,1,IDELIM,4)) 410,380,410
  410 IF (LCOMPS(KARTE,KARPOI,1,IDELIM,3)) 420,450,420
  420 IF (LCOMPS(KARTE,KARPOI,1,IZIFF,1)) 440,470,430
  430 IF (LCOMPS(KARTE,KARPOI,1,IZIFF,2)) 470,470,440
  440 IF (LCOMPS(KARTE,KARPOI,1,IZIFF,3)) 460,470,460
  450 IRC=118
      GO TO 999
  460 IRC=118
      GO TO 999
  470 IF (ICLPOS-9) 480,480,570
  480 CALL DB2208 (KARTE,KARPOI,KAREND,ZAHL(3),I)
      ICLAR(ICLPOS)=IZAHL(3)
      KARPOI=I
      GO TO 500
  490 KARPOI=KARPOI+1
  500 IF (LCOMPS(KARTE,KARPOI,1,IDELIM,1)) 510,520,510
  510 IF (LCOMPS(KARTE,KARPOI,1,IDELIM,5)) 20,530,20
  520 IF (KARPOI-KAREND) 490,640,640
  530 KARPOI=KARPOI+1
      KARPOS=KARPOI
      CALL DB2288 (KARTE,KARPOI,KAREND,KEYWD,NRPOS)
      IF (NRPOS-5) 540,550,540
  540 IRC=122
      GO TO 999
  550 ZAHL(3)=-ZAHL(3)
      ICLAR(ICLPOS)=IZAHL(3)
      GO TO 20
  560 ICLPOS=12
      GO TO 380
  570 CALL DB2286 (KARTE,KARPOI,KAREND,IZAHL(3),I)
      IF (I) 450,580,450
  580 IF (IZAHL(3)) 590,590,600
  590 IRC=124
      GO TO 999
  600 ICLAR(ICLPOS)=IZAHL(3)
      IF (ICLPOS-12) 20,610,20
  610 KARPOS=KARPOI
      CALL DB2288 (KARTE,KARPOI,KAREND,KEYWD,NRPOS)
      IF (NRPOS-15) 620,630,620
  620 ICLAR(L13)=ICLAR(L12)
      GO TO 30
  630 ICLPOS=13
      GO TO 380
  640 IF (ICLAR(L4)-ICLAR(L5)) 650,650,660
  650 IF (ICLAR(L6)-ICLAR(L7)) 670,670,660
  660 IRC=126
      GO TO 999
  670 IF (ICLAR(L12)-ICLAR(L13)) 999,999,680
  680 IRC=128
      GO TO 999
  990 IRC=6
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2295
      SUBROUTINE DB2295 (MNAR,IADZEL,IAR,NBRAS,
     1 NSYM,NBGTYP,NAT,NATDM,IRAD,IOXGET,IRC)
      DIMENSION MNAR(*),IAR(*),NBRAS(*),IRAD(*)
      DIMENSION IAIN(36),AIN(36),IBGTYP(2),ITMBUF(3),ITNBUF(2)
      COMMON /DC2201/ IFLAG(50)
      EQUIVALENCE (AIN(1),IAIN(1))
CHP8  DATA IBGTYP/'PFAB','CIRH'/,LCHAR/','/,IHXBLK/'    '/
Cmw      DATAIBGTYP/Z'D7C6C1C2',Z'C3C9D9C8'/,LCHAR/Z'6B404040'/,IHXBLK/Z'40
Cmw     $404040'/
      DATAIBGTYP/Z'C2C1C6D7',Z'C8D9C9C3'/,LCHAR/Z'4040406B'/,IHXBLK/Z'40
     $404040'/
      DATA IRC2/0/
      IVERFY=1
      IF (IFLAG(29)) 10,20,10
   10 IVERFY=0
   20 IRC=0
      NTOUT = IFLAG(33)
      NTDSPL = IFLAG(16)
      LEN=6+12*48+7*NATDM
      CALL DB2219(2295,10)
      CALL DB2231 (MNAR,LEN,IADZEL)
      IF (IADZEL) 40,30,50
   30 IADZEL=-2
   40 IRC=IADZEL
      GO TO 999
   50 IADSYM=IADZEL+6
      IADSSV=IADSYM
      IADPAR=IADSYM+573
      IADNAM=IADPAR+NATDM*3+1
      IADOXR=IADNAM+NATDM*2
      CALL DB2252 (8,1,IAR,NBRAS,NRC)
      IF (NRC) 60,60,80
   60 IF (IVERFY) 70,380,70
   70 IMSGNR=46
      GO TO 370
   80 DO 110 I=1,6
      CALL DB2259 (2*I-1,MNAR(IADZEL+I-1),NRC,NBRAS)
      IF (NRC) 90,110,110
   90 IF (IVERFY) 100,380,100
  100 IMSGNR=48
      GO TO 370
  110 CONTINUE
      CALL DB2334 (ITMBUF, MNAR(IADSYM),NSYM,NBGTYP,
     1 MNAR,IAR,NBRAS, NRC)
      IF (NRC) 380,120,380
  120 NAT=0
      CALL DB2252 (12,1,IAR,NBRAS,NRC)
      IF  (NRC) 130,130,150
  130 IF (IVERFY) 140,380,140
  140 IMSGNR=56
      GO TO 370
  150 I=1
  160 NAT=NAT+1
      IADPAR=IADPAR+3
      IADNAM=IADNAM+2
      IADOXR=IADOXR+2
      MNAR(IADNAM)=IHXBLK
      MNAR(IADNAM+1)=IHXBLK
      CALL DB2256 (1,MNAR(IADNAM),4,LEN,NBRAS)
      CALL DB2256 (2,MNAR(IADNAM+1),4,LEN,NBRAS)
      DO 220 J=1,3
      CALL DB2259 (2*J+4,AIN(1),NRC,NBRAS)
      IF (NRC) 320,170,170
  170 IF (ABS(AIN(1))-3.) 210,210,190
  190 CONTINUE
      CALL CICDCS (MNAR(IADNAM),1,8,ITMBUF(1))
      WRITE (NTDSPL,200) ITMBUF(1),ITMBUF(2),IFLAG(20)
  200 FORMAT (' DB2295 - invalid atomic parameter(s) for ',2A4,' in COL'
     1,I7)
      GO TO 380
  210 MNAR(IADPAR+J-1)=IAIN(1)
  220 CONTINUE
      IF (IOXGET) 330,330,230
  230 CALL DB2259 (3,MNAR(IADOXR),NRC,NBRAS)
      IF (NRC) 240,270,270
  240 IF (IVERFY) 250,380,250
  250 CONTINUE
      CALL CICDCS (MNAR(IADNAM),1,8,ITMBUF(1))
      WRITE (NTOUT,260) ITMBUF(1),ITMBUF(2)
  260 FORMAT (' DB2295 - Missing oxidation state for ',2A4,'.  Use DMAX
     1 parameter.')
      GO TO 380
  270 IAIN(1) = MNAR(IADOXR)
      CALL DB2333 (MNAR(IADNAM),AIN(1),AIN(2),IRAD,NRC)
      MNAR(IADOXR+1) = IAIN(2)
      IF (NRC-2) 340,300,280
  280 CONTINUE
      CALL CICDCS (MNAR(IADNAM),1,4,ITMBUF)
      WRITE (NTDSPL,290) ITMBUF(1),IFLAG(20)
  290 FORMAT (' DB2295 - Element ''',A2,''' not found. (COL',I7,')')
      GO TO 380
  300 IAIN(1)=MNAR(IADOXR)
      CALL CICDCS (MNAR(IADNAM),1,4,ITMBUF)
      WRITE (NTOUT,310) ITMBUF(1),AIN(1)
  310 FORMAT (' DB2295 - No ionic radius for ',A2,F5.1,' given.  Use DMA
     1X parameter.')
      GO TO 380
  320 NAT=NAT-1
      IADPAR=IADPAR-3
      IADNAM=IADNAM-2
      IADOXR=IADOXR-2
      GO TO 340
  330 MNAR(IADOXR)=0
      MNAR(IADOXR+1)=0
  340 I=I+1
      CALL DB2252 (12,I,IAR,NBRAS,NRC)
      IF (NRC) 999,999,350
  350 IF (NAT-NATDM) 160,360,360
  360 IMSGNR=58
  370 CALL DB2315 (IMSGNR,NBRAS)
  380 IRC=8
      CALL DB2219(2295,990)
      CALL DB2232 (MNAR,IADZEL,I)
      IF (I) 999,999,390
  390 IRC=-2
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2296
      SUBROUTINE DB2296 (AMNAR,IAR,NBRAS,ICLAR,IRC,IRAD)
      INTEGER DB2210
      COMMON /DC2201/ IFLAG(50)
      DIMENSION AMNAR(*),IAR(*),NBRAS(*),ICLAR(*),IRAD(*)
      DIMENSION KDMIR(2),AIN(2),IAIN(2)
      DIMENSION ICLAC(30)
      EQUIVALENCE (AIN(1),IAIN(1))
       DATA NATDM/300/,KDTO/4Hto: /,KDMIR/4H    ,4H*IR /
      DATA L2/2/,L4/4/,L5/5/,L6/6/,L7/7/,L8/8/,L9/9/
      DATA L10/10/,L11/11/,L12/12/,L13/13/
      NTOUT=IFLAG(33)
      IF (ICLAR(L10)) 40,10,40
   10 IF (IFLAG(32)-2) 20,50,20
   20 I1=ICLAR(L4)
      I2=ICLAR(L5)
      J1=ICLAR(L6)
      J2=ICLAR(L7)
      IF (DB2210(2)) 999,25,999
   25 CONTINUE
      CALL CICDCS (ICLAR,1,120,ICLAC)
      WRITE (NTOUT,30) (ICLAC(I),I=I1,I2),KDTO,(ICLAC(I),I=J1,J2)
   30 FORMAT (' from: ',12A4)
      GO TO 50
   40 ICLAR(L2)=1
   50 IAIN(1)=ICLAR(L8)
      IAIN(2)=ICLAR(L9)
      I1=1
      IF (AIN(1)) 60,70,70
   60 I1=2
      AIN(1)=-AIN(1)
   70 I2=1
      IF (AIN(2)) 80,90,90
   80 I2=2
      AIN(2)=-AIN(2)
   90 IF (ICLAR(L10)) 130,100,130
  100 IF (IFLAG(32)-2) 110,130,110
  110 WRITE (NTOUT,120) AIN(1),KDMIR(I1),AIN(2),KDMIR(I2),ICLAR(L12),
     1 ICLAR(L13)
  120 FORMAT (' Dmin:',F10.5,A4,' Dmax:',F10.5,A4,4X,'coordination',
     1 I4,' to',I4)
  130 I1=I1+I2-2
  140 ICLAR(L11)=0
      CALL DB2295 (AMNAR,IADZEL,IAR,NBRAS,NSYM,NBGTYP,
     1 NAT,NATDM,IRAD,I1,IRC)
      IF (IRC) 999,150,999
  150 IADSYM=IADZEL+6
      IADPAR=IADSYM+576
      IADNAM=IADPAR+3*NATDM
      IADOXR=IADNAM+2*NATDM
      LEN=3483
      CALL DB2219 (2296,50)
      CALL DB2231 (AMNAR,LEN,IADZEN)
      IF (IADZEN) 170,160,180
  160 IADZEN=-2
  170 IRC=IADZEN
      GO TO 190
  180 IADWNK=IADZEN+783
      IADITO=IADWNK+1500
      IADATO=IADITO+400
      CALL DB2297 (AMNAR(IADZEL),AMNAR(IADSYM),NSYM,NBGTYP,
     1 AMNAR(IADPAR),AMNAR(IADNAM),AMNAR(IADOXR),NAT,AMNAR(IADZEN),
     2 AMNAR(IADWNK),AMNAR(IADITO),AMNAR(IADATO),ICLAR)
      CALL DB2219 (2296,130)
      CALL DB2232 (AMNAR,IADZEN,I)
      IF (I) 200,190,200
  190 CALL DB2219 (2296,140)
      CALL DB2232 (AMNAR,IADZEL,I)
      IF (I) 200,999,200
  200 IRC=-2
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2297
      SUBROUTINE DB2297 (ZELLE,SYM,NSYM,NBGTYP,AT,NAMAT,OXSTFR,NAT,
     1                   ZENTR,WINKEL,ITO,ATO,ICLAR)
      INTEGER DB2210
      COMMON /DC2201/ IFLAG(50)
      DIMENSION ZELLE(6),SYM(12,*),NAMAT(2,*),OXSTFR(2,*),ICLAR(30)
      DIMENSION AT(3,*),ITO(4,*),ATO(8,*),ITOS(4),ATOS(8)
      DIMENSION ATOMS(7,20),ITOMS(2,20),WINKEL(5,*),ZENTR(3,*)
      DIMENSION ICLAC(6)
      EQUIVALENCE (HILF,IHILF),(IVON,AIVON)
      EQUIVALENCE (IPHFKT,SPHFKT),(IDMINF,DMINF)
CHP8  DATA NCDDM/20/,NITODM/100/,IBLAN/'    '/,INKDM/300/,OXMIN/-9./
      DATANCDDM/20/,NITODM/100/,IBLAN/Z'40404040'/,INKDM/300/,OXMIN/-9./
CHP8  DATA KDALL/'ALL '/,IZENDM/261/
Cmw      DATAKDALL/Z'C1D3D340'/,IZENDM/261/
      DATAKDALL/Z'40D3D3C1'/,IZENDM/261/
      NTOUT=IFLAG(33)
      NTDSPL=IFLAG(16)
      ISFFLG=0
      IF (ICLAR(10)) 40,10,40
   10 IF (IFLAG(32)-2) 20,70,20
   20 WRITE (NTOUT,30)
   30 FORMAT (' ',22(1H-),' Interatomic distances ' ,23(1H-),/,
     1 ' Origin Sphere   Distances to neighbours (distance, atom, identi
     2fier)')
      GO TO 70
   40 IF (ICLAR(12)-1) 70,50,70
   50 IF (ICLAR(13)-999) 70,60,60
   60 ISFFLG=1
   70 IZENTP=0
      INKP=0
      IFLG=0
      IPHFKT=ICLAR(9)
      IDMINF=ICLAR(8)
      CALL DB2290 (ZELLE,ZELVOL,NBGTYP)
      DO 830 IUR=1,NAT
      I1=ICLAR(4)
      I2=ICLAR(5)
      DO 80 I=I1,I2
      IF (ICLAR(I) .EQ. KDALL) GO TO 90
      IF (ICLAR(I) .EQ. NAMAT(1,IUR)) GO TO 90
   80 CONTINUE
      GO TO 830
   90 IHIGH=0
      NITO=0
      DO 290 IZL=1,NAT
      I1=ICLAR(6)
      I2=ICLAR(7)
      DO 100 I=I1,I2
      IF (ICLAR(I) .EQ. KDALL) GO TO 110
      IF (ICLAR(I) .EQ. NAMAT(1,IZL)) GO TO 110
  100 CONTINUE
      GO TO 290
  110 IF (SPHFKT) 130,120,120
  120 DMAX=SPHFKT
      GO TO 140
  130 DMAX=-(OXSTFR(2,IUR)+OXSTFR(2,IZL))*SPHFKT
  140 IF (DMINF) 150,160,160
  150 DMIN=-(OXSTFR(2,IUR)+OXSTFR(2,IZL))*DMINF
      GO TO 170
  160 DMIN=DMINF
  170 CALL DB2291 (AT,SYM,NSYM,ITOMS,ATOMS,NCDDM,
     1 IUR,IZL,IZL,DMIN,DMAX,0,NCD,IRC)
      IF (IRC-8) 200,830,180
  180 IHIGH=1
      CALL CICDCS ( NAMAT(1,IZL),1,8,ICLAC(1))
      CALL CICDCS ( NAMAT(1,IUR),1,8,ICLAC(3))
      WRITE (NTOUT,190) (ICLAC(II),II=1,4),IFLAG(20)
  190 FORMAT (' Not all atoms ',A3,A4,' shown around ',
     1 A3,A4,' (sphere too large). COL=',I7)
  200 IF (NCD-1) 290,290,210
  210 IF (ISFFLG) 220,230,220
  220 ICLAR(11)=1
      GO TO 9999
  230 DO 280 I=2,NCD
      IF (NITO-NITODM) 250,240,240
  240 IHIGH=1
      GO TO 300
  250 NITO=NITO+1
      DO 260 J=1,2
  260 ITO(J,NITO)=ITOMS(J,I)
      K=ITO(1,NITO)/1000000
      ITO(3,NITO)=NAMAT(1,K)
      ITO(4,NITO)=NAMAT(2,K)
      DO 270 J=1,7
  270 ATO(J,NITO)=ATOMS(J,I)
      ATO(8,NITO)=DMAX
  280 CONTINUE
  290 CONTINUE
  300 IF (NITO-ICLAR(12)) 830,310,310
  310 IF (NITO-ICLAR(13)) 320,320,830
  320 ICLAR(11)=1
      IF (ICLAR(10)) 9999,330,9999
  330 IF (NITO-1) 830,480,340
  340 DO 470 I=2,NITO
      J=I
      DO 350 K=1,8
  350 ATOS(K)=ATO(K,J)
      DO 360 K=1,4
  360 ITOS(K)=ITO(K,J)
  370 J=J-1
      IF (J) 440,440,380
  380 IF (ITOS(3)-ITO(3,J)) 410,390,440
  390 IF (ATOS(8)-ATO(8,J)) 410,400,440
  400 IF (ATOS(1)-ATO(1,J)) 410,440,440
  410 DO 420 K=1,8
  420 ATO(K,J+1)=ATO(K,J)
      DO 430 K=1,4
  430 ITO(K,J+1)=ITO(K,J)
      GO TO 370
  440 DO 450 K=1,8
  450 ATO(K,J+1)=ATOS(K)
      DO 460 K=1,4
  460 ITO(K,J+1)=ITOS(K)
  470 CONTINUE
  480 NAM1=NAMAT(1,IUR)
      NAM2=NAMAT(2,IUR)
      IF (IFLAG(32)-2) 520,490,520
  490 DO 510 I=1,NITO
      CALL CICDCS (NAM1,1,4,ICLAC(1))
      CALL CICDCS (NAM2,1,4,ICLAC(2))
      CALL CICDCS (ITO(3,I),1,8,ICLAC(3))
      WRITE (NTOUT,500) (ICLAC(II),II=1,4),ATO(8,I),ATO(1,I)
  500 FORMAT (' 9000   ',2A3,2X,2A3,2F8.4)
  510 CONTINUE
      GO TO 660
  520 IVON=1
  530 IELOLD=ITO(3,IVON)
      SPHOLD=ATO(8,IVON)
      IBIS=IVON
  540 IF (IBIS-NITO) 550,580,580
  550 IBIS=IBIS+1
      IF (IELOLD-ITO(3,IBIS)) 570,560,570
  560 IF (SPHOLD-ATO(8,IBIS)) 570,540,540
  570 IBIS=IBIS-1
  580 J1=IVON
      J2=MIN0(J1+3,IBIS)
      IF (DB2210(1)) 9999,590,9999
  590 CONTINUE
      CALL CICDC (NAM1,1,4)
      CALL CICDC (NAM2,1,4)
      DO 595 I=J1,J2
      CALL CICDC (ITO(3,I),1,8)
  595 CONTINUE
      WRITE (NTOUT,600) NAM1,NAM2,SPHOLD,
     1 (ATO(1,I),ITO(3,I),ITO(4,I),I=J1,J2)
  600 FORMAT (1H ,A3,A4,F6.3,3X,4(F5.3,1X,A3,A4,1X))
      GO TO 640
  610 J1=J1+4
      J2=MIN0(J1+3,IBIS)
      IF (DB2210(1)) 9999,620,9999
  620 CONTINUE
      DO 525 I=J1,J2
      CALL CICDC (ITO(3,I),1,8)
  525 CONTINUE
      WRITE (NTOUT,630) (ATO(1,I),ITO(3,I),ITO(4,I),I=J1,J2)
  630 FORMAT (' ',16X,4(F5.3,1X,A3,A4,1X))
  640 IF (J2-IBIS) 610,650,650
  650 NAM1=IBLAN
      NAM2=IBLAN
      IVON=IBIS+1
      IF (IVON-NITO) 530,530,660
  660 IF (ICLAR(2)-2) 830,670,830
  670 IF (IFLG) 830,680,830
  680 IF (OXSTFR(1,IUR)-OXMIN) 830,690,690
  690 IF (NITO-2) 830,700,700
  700 IF (IZENTP-IZENDM-1) 710,820,820
  710 IZENTP=IZENTP+1
      IHILF=NAMAT(1,IUR)
      ZENTR(1,IZENTP)=HILF
      IHILF=NAMAT(2,IUR)
      ZENTR(2,IZENTP)=HILF
      IHILF=INKP+1
      ZENTR(3,IZENTP)=HILF
      IBIS=NITO-1
      DO 800 J=1,IBIS
      IVON=J+1
      DO 790 K=IVON,NITO
      TEMP2=ATO(1,J)*ATO(1,K)
      IF (TEMP2) 790,790,720
  720 TEMP=0.
      DO 730 I=5,7
  730 TEMP=TEMP+(ATO(I,J)-ATOMS(I,1))*(ATO(I,K)-ATOMS(I,1))
      TEMP=TEMP/TEMP2
      IF (TEMP+1.) 740,740,750
  740 TEMP=180.
      GO TO 780
  750 IF (TEMP-1.) 770,760,760
  760 TEMP=0.
      GO TO 780
  770 CONTINUE
      TEMP=A COS(TEMP)*57.29578
      IF (INKP-INKDM) 780,820,820
  780 INKP=INKP+1
      WINKEL(1,INKP)=TEMP
      IHILF=ITO(3,J)
      WINKEL(2,INKP)=HILF
      IHILF=ITO(4,J)
      WINKEL(3,INKP)=HILF
      IHILF=ITO(3,K)
      WINKEL(4,INKP)=HILF
      IHILF=ITO(4,K)
      WINKEL(5,INKP)=HILF
  790 CONTINUE
  800 CONTINUE
      HILF=ZENTR(3,IZENTP)
      IF (IHILF-INKP) 830,830,810
  810 INKP=INKP-1
      GO TO 830
  820 IFLG=1
  830 CONTINUE
      IHILF=INKP+1
      ZENTR(3,IZENTP+1)=HILF
      IF (INKP) 9999,9999,840
  840 IF (IFLAG(32)-2) 850,940,850
  850 WRITE (NTOUT,860)
  860 FORMAT (' ',25(1H-),' Bonding angles ',25(1H-),/,
     1 ' Origin   Angles to neighbours')
      DO 930 IUR=1,IZENTP
      AIVON=ZENTR(3,IUR)
      HILF=ZENTR(3,IUR+1)
      IBIS=IHILF-1
      J1=IVON
      J2=MIN0(J1+2,IBIS)
      IF (DB2210(1)) 9999,870,9999
  870 CONTINUE
      CALL CICDCS (ZENTR(1,IUR),1,8,ICLAC)
      WRITE (NTOUT,880) ICLAC(1),ICLAC(2),
     1 ((WINKEL(I,J),I=1,5),J=J1,J2)
  880 FORMAT (' ',2A3,3(F7.2,1X,2A3,' ',2A3))
      GO TO 920
  890 J1=J1+3
      J2=MIN0(J1+2,IBIS)
      IF (DB2210(1)) 9999,900,9999
  900 WRITE (NTOUT,910) ((WINKEL(I,J),I=1,5),J=J1,J2)
  910 FORMAT (' ',6X,3(F7.2,1X,2A3,' ',2A3))
  920 IF (J2-IBIS) 890,930,930
  930 CONTINUE
      GO TO 980
  940 DO 970 IUR=1,IZENTP
      AIVON=ZENTR(3,IUR)
      HILF=ZENTR(3,IUR+1)
      IBIS=IHILF-1
      DO 960 IZL=IVON,IBIS
      CALL CICDCS (WINKEL(2,IZL),1,8, ICLAC(1))
      CALL CICDCS (ZENTR(1,IUR),1,8, ICLAC(3))
      CALL CICDCS (WINKEL(4,IZL),1,8, ICLAC(5))
      WRITE (NTOUT,950) (ICLAC(I),I=1,6),WINKEL(1,IZL)
  950 FORMAT (' 9100   ',3(2A3,2X),F7.2)
  960 CONTINUE
  970 CONTINUE
  980 IF (IFLG) 990,9999,990
  990 WRITE (NTDSPL,1000)
 1000 FORMAT (' DB2297 - List exceeds buffer size.  Calculation of angle
     1s terminated.')
 9999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880229--DB2298
                   SUBROUTINE DB2298 (SYM,NSYM,NTYP)
      DIMENSION SYM(12,*)
      IEND=NSYM
      IF (NTYP-1) 999,10,999
   10 DO 50 I=1,IEND
      NSYM=NSYM+1
      DO 20 M=1,12
   20 SYM(M,NSYM)=-SYM(M,I)
      DO 40 M=1,9,4
      IF (SYM(M,NSYM)) 30,40,40
   30 SYM(M,NSYM)=SYM(M,NSYM)+1.
   40 CONTINUE
   50 CONTINUE
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2300
      SUBROUTINE DB2300 (MNAR,IADR,ICOUNT,IRC)
      DIMENSION MNAR(*)
      COMMON /DC2227/ IBTMAX,IBITT(64)
      IRC=0
      CALL DB2222 (MNAR,IADR,ICOUNT)
      IF (ICOUNT) 10,20,20
  10  IRC=ICOUNT
      GO TO 999
  20  IF (MNAR(IADR)-1) 40,31,30
  30  IRC=-2
      GO TO 999
  31  LENL=MNAR(IADR+1)
      IMAX=MNAR(IADR+LENL+3)
      LENB=IMAX/32+1
      IF (LENB-LENL) 32,999,999
  32  CALL DB2225 (MNAR,IADRB,IADR,1,IRC)
      IF (IRC) 999,34,30
  34  CALL DB2232 (MNAR,IADR,IRC)
      IF (IRC) 999,35,30
  35  IADR=IADRB
      GO TO 999
  40  LENB=MNAR(IADR+1)
      IF (LENB) 30,45,50
  45  MNAR(IADR+2)=0
      GO TO 999
  50  LENBN=LENB
      J1=IADR+4
      J2=IADR+3+LENB
  60  IF (MNAR(J2)) 80,70,80
  70  LENBN=LENBN-1
      J2=J2-1
      IF (J2-J1) 80,60,60
  80  LENL=ICOUNT
      IF (LENL-LENBN) 110,90,90
  90  IF (LENBN-LENB) 100,999,30
 100  MNAR(IADR+1)=LENBN
      CALL DB2234 (MNAR,LENBN+4,IADR,IRC)
      GO TO 999
 110  CALL DB2231 (MNAR,LENL+4,IADRL)
      IF (IADRL) 120,30,160
 120  IRC=IADRL
      GO TO 999
 160  MNAR(IADRL)=1
      MNAR(IADRL+1)=LENL
      MNAR(IADRL+2)=0
      MNAR(IADRL+3)=0
      IF (LENL) 20,999,170
  170 L1=IADRL+3
      K2=-1
  175 ITMP=MNAR(J1)
      IF (ITMP) 180,210,180
  180 DO 200 J=1,32
      IF (LAND(ITMP,IBITT(J))) 190,200,190
  190 L1=L1+1
      MNAR(L1)=K2+J
  200 CONTINUE
  210 K2=K2+32
      J1=J1+1
      IF (J1-J2) 175,175,220
  220 CALL DB2232 (MNAR,IADR,IRC)
      IF (IRC) 999,230,20
  230 IADR=IADRL
  999 CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD861217--DB2302
      SUBROUTINE DB2302 (KARPOI,ICLAR,IRC)
      DIMENSION ICLAR(*),LTYPE(10),KTYPE(10),NTYPE(10)
      COMMON /DC2280/ NTIN,NTDSPL,NTPRT,KARTE(60),KARDMY,KAREND,KDSEMI
      COMMON /DC2280/ IVERFY(20)
CHP8  DATA LTYPE/'NAME','*%#@','MINR','FORM','TITL','AUT','TYPE','REM',
C    1 'CAS','PICT'/
Cmw      DATALTYPE/Z'D5C1D4C5',Z'5C6C7B7C',Z'D4C9D5D9',Z'C6D6D9D4',Z'E3C9E3
Cmw     $D3',Z'C1E4E340',Z'E3E8D7C5',Z'D9C5D440',Z'C3C1E240',Z'D7C9C3E3'/
      DATALTYPE/Z'C5D4C1D5',Z'7C7B6C5C',Z'D9D5C9D4',Z'D4D9D6C6',Z'D3E3C9
     $E3',Z'40E3E4C1',Z'C5D7E8E3',Z'40D4C5D9',Z'40E2C1C3',Z'E3C3C9D7'/
CHP8  DATA KTYPE/'N','*','M','F','T','A','T','Z','H','K'/
Cmw      DATAKTYPE/Z'D5404040',Z'5C404040',Z'D4404040',Z'C6404040',Z'E34040
Cmw     $40',Z'C1404040',Z'E3404040',Z'E9404040',Z'C8404040',Z'D2404040'/
      DATAKTYPE/Z'404040D5',Z'4040405C',Z'404040D4',Z'404040C6',Z'404040
     $E3',Z'404040C1',Z'404040E3',Z'404040E9',Z'404040C8',Z'404040D2'/
      DATA NTYPE/1,2,3,4,5,7,11,16,17,19/
CHP8  DATA ITYPMX/10/,KDIN/'IN  '/,KDELE/'ELE '/
Cmw      DATAITYPMX/10/,KDIN/Z'C9D54040'/,KDELE/Z'C5D3C540'/
      DATAITYPMX/10/,KDIN/Z'4040D5C9'/,KDELE/Z'40C5D3C5'/
      DATA L2/2/,L3/3/,L4/4/,L5/5/
      KARPOS=KARPOI
      CALL DB2289 (KARTE,KARPOI,KAREND,ICLAR,100,IRC)
      IF (IRC) 999,5,999
   5  IF (ICLAR(1)) 6,6,10
   6  IRC=1
      GO TO 999
  10  CALL DB2283 (KARPOI,ICLAR,IRC)
      IF (IRC) 999,20,999
  20  IF (ICLAR(L3) .EQ. KDIN ) GO TO 30
      IF (ICLAR(L3) .EQ. KDELE) GO TO 30
  25  IRC=10
      GO TO 999
  30  ICLAR(1)=4
      ICLAR(L2)=4
      DO 40 I=1,ITYPMX
      IF (ICLAR(L5) .EQ. LTYPE(I)) GO TO 50
      IF (ICLAR(L5) .EQ. KTYPE(I)) GO TO 50
  40  CONTINUE
      GO TO 25
  50  ICLAR(L3)=NTYPE(I)
      CALL DB2289 (KARTE,KARPOS,KAREND,ICLAR(L4),100,IRC)
 999  RETURN
      END
C ----------------------------------------OWNUNC411----UPD860109--DB2313
      SUBROUTINE DB2313(IMEM,IBLA,MNAR,NBRAS,IMADR,MEML,IRC)
      DIMENSION NBRAS(*),MNAR(*)
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2206/ ICSDCB(64),ITABCB(64),ICS2CB(64)
      NDSPL = IFLAG(16)
      IRC = 0
      CALL DB0128(IMEM,IDIR,NPOS,MEML,ITABCB,NBRAS)
      IF(MEML .LE. 0) GO TO 1000
      CALL DB2219(2313,100)
      CALL DB2231(MNAR,(MEML+3)/4,IMADR)
      IF(IMADR .LT. 0) GO TO 9800
      CALL DB0101(IFLAG(21),NPOS,MNAR(IMADR),0,MEML,NBRAS)
      GO TO 9900
1000  IRC = 1
      IF(IBLA .NE. 0) WRITE(NDSPL,1020) IMEM,IFLAG(21)
1020  FORMAT(' TABLE #',I5,' NOT FOUND IN FILE',I4)
      GO TO 9900
9800  IRC = IMADR
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2314
      SUBROUTINE DB2314(MNAR,IADR,ICLAR,IRC,NBRAS)
      INTEGER DB2210
      DIMENSION MNAR(*),ICLAR(*),NBRAS(*),IHELP(2)
      DIMENSION ICLARE(30),LINE(18)
      COMMON /DC2201/ IFLAG(50)
CHP8  DATA ICK/'K'/, ICD/'D'/, ICN/'N'/, ICY/'Y'/, IFRAG/'H'/
Cmw      DATAICK/Z'D2404040'/,ICD/Z'C4404040'/,ICN/Z'D5404040'/,ICY/Z'E8404
Cmw     $040'/,IFRAG/Z'C8404040'/
      DATAICK/Z'404040D2'/,ICD/Z'404040C4'/,ICN/Z'404040D5'/,ICY/Z'40404
     $0E8'/,IFRAG/Z'404040C8'/
CHP8  DATA IHELP/'DB23','14H1'/, IBLANK/'   '/, ICS/'S'/
Cmw      DATAIHELP/Z'C4C2F2F3',Z'F1F4C8F1'/,IBLANK/Z'40404040'/,ICS/Z'E2404
Cmw     $040'/
      DATAIHELP/Z'F3F2C2C4',Z'F1C8F4F1'/,IBLANK/Z'40404040'/,ICS/Z'40404
     $0E2'/
      DATA L2/2/
      INI = 0
      LNGA = 0
      IHIT = 0
      ISCNT = 0
      ITYPAR = 0
      NPRINT = IFLAG(33)
      NINPT = IFLAG(25)
      NDEV = IFLAG(32)
      IDBCB = IFLAG(40)
      IACTBS = MNAR(IDBCB+3)
      IF (IACTBS .EQ. 0) CALL DB2315(88,NBRAS)
      KFIRST = IDBCB + MNAR(IDBCB+1)
      LENDKB = MNAR(IDBCB)
      CALL DB2313(120,1,MNAR,NBRAS,IRAD,IRADL,IRG)
      IRG = IRG + 3
      GO TO (3200,3100,200,3200), IRG
200   ICLARE(2)=ICLAR(L2)
      KARPOI = 13
      CALL DB2294(ICLAR,KARPOI,120,ICLARE,IRK)
      IF (IRK .GT. 100) CALL DB2315(IRK,NBRAS)
      IF (IRK .NE. 0) GO TO 3060
      ISELCT = ICLARE(10)
      IFLAG(29) = ISELCT
      IF(ISELCT .EQ. 0) J = DB2210(0)
      IF(ISELCT .EQ. 0) GO TO 300
      IF(IFLAG(32) .NE. 0) GO TO 3050
      CALL DB2229(MNAR,IADR,KOPIE,IRK)
      IF(IRK+1) 3200,3100,400
300   KOPIE = IADR
400   CALL DB2221(MNAR,KOPIE,1,IREL)
      IFUNK = 0
500   CALL DB2221(MNAR,KOPIE,IFUNK,IREL)
      IF(IREL .EQ. 0) GO TO 2000
      IF(ISELCT .EQ. 1) GO TO 504
      IF(NDEV .NE. 0) GO TO 580
      IF(INI .EQ. 0) GO TO 580
501   WRITE(NPRINT,502)
502   FORMAT(' Load next entry of current subset (Y/N)?')
      CALL KEYBRD(NINPT,IANTW,1)
      IF(IANTW .EQ. ICN) GO TO 2000
      IF(IANTW .EQ. ICY) GO TO 580
      CALL DB2315(22,NBRAS)
      GO TO 501
504   IF(MOD(ISCNT,IFLAG(26)) .NE. 0) GO TO 580
      IF(ISCNT .EQ. 0) GO TO 580
505   WRITE(NPRINT,510) ISCNT,IHIT
510   FORMAT(1X,I6,' Entries scanned.',I6,' Hits. Continue(Y/N)?')
      CALL KEYBRD(NINPT,IANTW,1)
      IF(IANTW .EQ. ICY) GO TO 580
      IF(IANTW .EQ. ICN) GO TO 2000
      WRITE(NPRINT,2180)
      GO TO 505
580   ISCNT = ISCNT + 1
      INI = 1
      IF(IACTBS .EQ. 0) GO TO 2000
      JP = KFIRST
      DO 582 JBAS = 1,IACTBS
      IZUG = MNAR(JP + 66)
      IF(IREL .LE. (IZUG + MNAR(JP+130))) GO TO 585
      JP = JP + LENDKB
582   CONTINUE
      GO TO 2000
585   ICSX = MNAR(JP+64)
      CALL DB2250(IREL-IZUG,IZREC,MNAR(JP),NBRAS,IRK)
      IF(IRK .NE. 0) GO TO 940
595   LNGB = 3*IZREC + 60
      IF(LNGB .LE. LNGA) GO TO 700
      IF(LNGA .EQ. 0) GO TO 600
      CALL DB2219(2314,600)
      CALL DB2232(MNAR,ITYPAR,IRK)
      IF(IRK .NE. 0) GO TO 3200
600   CONTINUE
      CALL DB2219(2314,610)
      CALL DB2231(MNAR,LNGB,IRK)
      IF(IRK .LE. 0) GO TO 3100
      ITYPAR = IRK
      LNGA = LNGB
700   CALL DB2251(MNAR(ITYPAR),LNGB,NBRAS,ICOL)
      IF(ICOL .LE. 0) GO TO 3200
      IFLAG(36) = 0
      IF(ICOL .LT. 800000) GO TO 720
      IF(ICOL .GE. 900000) GO TO 720
      IFLAG(36) = 1
720   IF(ISELCT .EQ. 1) GO TO 800
      IF(NDEV .EQ. 2) GO TO 770
      IF(DB2210(3) .NE. 0) GO TO 2000
      DO 740 J = 1,18
740   LINE(J) = IBLANK
      CALL DB2252(4,1,MNAR(ITYPAR),NBRAS,IRK)
      IF(IRK .LE. 0) GO TO 750
      CALL DB2260(1,LINE,70,LEN,NBRAS)
750   CONTINUE
      CALL CICDC(LINE,1,70)
      WRITE(NPRINT,760) ICOL,IREL,LINE
760   FORMAT(/,' Distances in COL=',I6,'  (REL=',I6,')',/,1X,17A4,A2)
      GO TO 800
770   WRITE(NPRINT,780) ICOL,IREL
780   FORMAT('000    ',2I7,59X)
800   CONTINUE
      CALL DB2296(MNAR,MNAR(ITYPAR),NBRAS,ICLARE,IRK,MNAR(IRAD))
      IRK = IRK + 3
      GO TO (3200,3100,900,940), IRK
900   IF(ISELCT .EQ. 0) GO TO 940
      IF(ICLARE(11) .EQ. 1) GO TO 1000
940   IFUNK = 0
      GO TO 500
1000  IHIT = IHIT + 1
      IFUNK = -1
      GO TO 500
2000  CALL DB2221(MNAR,KOPIE,2,IREL)
      J = -1
      CALL DB2292(MNAR,J,J,J,ICLARE,J,J,J,IRK)
      IF(IRK .NE. 0) GO TO 3200
      IF(ISELCT .EQ. 0) GO TO 3040
      WRITE(NPRINT,2100) IHIT
2100  FORMAT(' Specified distance found in',I6,' entries.')
      IF(IHIT .EQ. 0) GO TO 3000
2120  CALL DB2315(40,NBRAS)
      CALL KEYBRD(NINPT,IANTW,1)
      IF(IANTW .EQ. ICK) GO TO 2200
      IF(IANTW .EQ. ICD) GO TO 2600
      IF(IANTW .EQ. ICS) GO TO 2640
      IF(IANTW .EQ. ICN) GO TO 3000
      IF(IANTW .EQ. IFRAG) GO TO 2700
      WRITE(NPRINT,2180)
2180  FORMAT(' Ill. response.')
      GO TO 2120
2200  CALL DB2224(MNAR,IADR,KOPIE,IRK)
      IF(IRK+1) 3200,3100,3000
2600  CALL DB2219(2314,2600)
      CALL DB2232(MNAR,IADR,IRK)
      IF(IRK .NE. 0) GO TO 3200
      IADR = KOPIE
      GO TO 3040
2640  CALL DB2315(38,NBRAS)
      CALL KEYBRD(NINPT,LINE(2),2)
      IF(LCOMP(LINE(2),IBLANK,1) .NE. 0) GO TO 2660
      CALL DB2315(42,NBRAS)
      GO TO 2640
2660  CALL DB2229(MNAR,IADR,KOPIE2,IRK)
      IF(IRK+1) 3200,3100,2665
2665  CALL DB2224(MNAR,KOPIE2,KOPIE,IRK)
      IF(IRK+1) 3200,3100,2670
2670  LINE(1) = 2
      LINE(4) = KOPIE2
      CALL DB2316(LINE,J,MNAR,NBRAS,IRK)
      IRK = IRK + 3
      GO TO (3200,3100,2680,3200), IRK
2680  CALL DB2219(2314,2680)
      CALL DB2232(MNAR,KOPIE2,IRK)
      IF(IRK) 3200,3000,3200
2700  CALL DB2217(MNAR,IHELP,NBRAS,IRK)
      GO TO 2120
3000  CALL DB2219(2314,3000)
      CALL DB2232(MNAR,KOPIE,IRK)
      IF(IRK) 3200,3040,3200
3040  IRC = 0
      IF(ISELCT .EQ. 1) IRC = -2
      GO TO 9000
3050  CALL DB2315(60,NBRAS)
3060  IRC = -1
      GO TO 9000
3100  IRC = 1
      GO TO 9900
3200  IRC = 2
      GO TO 9900
9000  IF(ITYPAR .EQ. 0) GO TO 9100
      CALL DB2219(2314,9000)
      CALL DB2232(MNAR,ITYPAR,IRK)
      IF(IRK .NE. 0) GO TO 3200
9100  CALL DB2232(MNAR,IRAD,IRK)
      IF(IRK .NE. 0) GO TO 3200
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2315
      SUBROUTINE DB2315(IMES,NBRAS)
      DIMENSION LINE(18),NBRAS(*)
      COMMON /DC2201/ IFLAG(50)
      IFLG = 30
      IME = IMES
      IF(IME .LT. 100) GO TO 60
      IFLG = 42
      IME = IME - 100
60    NDSPL = IFLAG(16)
      NPOS = (IME - 1 + IFLAG(28)) * 72  + IFLAG(IFLG)
      CALL DB2317(IFLAG(21),NPOS,LINE,0,72,NBRAS)
      CALL CICDC(LINE,1,70)
      WRITE(NDSPL,100) LINE
100   FORMAT(1X,17A4,A2)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2316
      SUBROUTINE DB2316(INPUT,IBACK,MNAR,NBRAS,IRC)
      DIMENSION INPUT(*),NBRAS(*),MNAR(*),IUTAB(2,10),NFCBSC(64)
      DIMENSION INISAV(3)
      COMMON /DC2201/ IFLAG(50)
CHP8  DATA MXUTAB/10/, IBLANK/'    '/, INITI/0/, INISCR/0/
      DATAMXUTAB/10/,IBLANK/Z'40404040'/,INITI/0/,INISCR/0/
      DATA INT2,INT3,INT4,INT5 /2,3,4,5/
      NDSPL = IFLAG(16)
      IFUNC = INPUT(1)
      IF(IFUNC .GT. 1) GO TO 200
      DO 100 J = 1,3
100   INISAV(J) =  INPUT(J)
      INITI = 0
      GO TO 9000
200   IF(INITI .NE. 0) GO TO 400
      NCRF = INISAV(2)
      NBLK = INISAV(3)
      IF(INISCR .NE. 0) GO TO 260
      DO 240 J = 1,NBLK
240   CALL DB0107(INISAV(2),J,J,MNAR    ,760)
      INISCR = 1
260   CALL DB0112(INISAV(2),MXUTAB,NBLK,3040,NFCBSC,NBRAS)
      DO 300 J = 1,MXUTAB
300   IUTAB(1,J) = IBLANK
      INITI = 1
400   GO TO (9000,1000,3000,4000,5000,6000), IFUNC
1000  DO 1020 J = 1,MXUTAB
      IF(IUTAB(1,J) .EQ. IBLANK) GO TO 1020
      IF(IUTAB(1,J) .NE. INPUT(INT2)) GO TO 1020
      IF(IUTAB(2,J) .EQ. INPUT(INT3)) GO TO 1040
1020  CONTINUE
      GO TO 1080
1040  IRC = 0
      IMES = 30
      GO TO 9400
1080  DO 1100 JTB = 1,MXUTAB
      IF(IUTAB(1,JTB) .EQ. IBLANK) GO TO 1200
1100  CONTINUE
      IRC = 0
      IMES= 24
      GO TO 9400
1200  LEN = (MNAR(INPUT(INT4)+1) + 4) * 4
      CALL DB0123(JTB,MNAR(INPUT(INT4)),0,LEN,IRK,NFCBSC,NBRAS)
      IF(IRK .NE. -5) GO TO 1240
      IMES = 28
      IRC = 0
      GO TO 9400
1240  IF(IRK .GE. -1) GO TO 1260
      IMES = 26
      IRC = -2
      GO TO 9400
1260  IUTAB(1,JTB) = INPUT(INT2)
      IUTAB(2,JTB) = INPUT(INT3)
      GO TO 9000
3000  DO 3100 JTB = 1,MXUTAB
      IF(INPUT(INT2) .NE. IUTAB(1,JTB)) GO TO 3100
      IF(INPUT(INT3) .EQ. IUTAB(2,JTB)) GO TO 3200
3100  CONTINUE
      IMES = 32
      IRC = 1
      GO TO 9400
3200  IUTAB(1,JTB) = IBLANK
      CALL DB0126(JTB,NFCBSC,NBRAS)
      GO TO 9000
4000  DO 4100 J = 1,MXUTAB
      IF (IUTAB(1,J) .EQ. IBLANK) GO TO 4100
      CALL CICDCS(IUTAB(1,J),1,4,JUNK1)
      CALL CICDCS(IUTAB(2,J),1,4,JUNK2)
      WRITE(NDSPL,4020) JUNK1,JUNK2
4020  FORMAT(1X,2A4)
4100  CONTINUE
      GO TO 9000
5000  CALL DB2219(2316,5000)
      LEN = 2 * NFCBSC(32)
      CALL DB2231(MNAR,LEN,NSORT)
      IF(NSORT .LT. 0) GO TO 9300
      MEMBIG = 4000
      CALL DB2219(2316,5010)
      CALL DB2231(MNAR,MEMBIG,IENTBF)
      IF(IENTBF .LT. 0) GO TO 9300
      IRK = 1
      CALL DB0152(MNAR(NSORT),MNAR(IENTBF),MEMBIG,NFCBSC,NBRAS,IRK)
      CALL DB2219(2316,5020)
      CALL DB2232(MNAR,NSORT,IRC)
      IF(IRC .NE. 0) GO TO 9100
      CALL DB2219(2316,5030)
      CALL DB2232(MNAR,IENTBF,IRC)
      IF(IRC .NE. 0) GO TO 9100
      IF(IRK .EQ. 0) GO TO 9000
      IMES = 36
      IRC = -2
      GO TO 9400
6000  DO 6100 JTB = 1,MXUTAB
      IF(IUTAB(1,JTB) .NE. INPUT(INT4)) GO TO 6100
      IF(IUTAB(2,JTB) .EQ. INPUT(INT5)) GO TO 6200
6100  CONTINUE
      IMES = 32
      IRC = 1
      GO TO 9400
6200  CALL DB0128(JTB,IDIR,NPOS,MEML,NFCBSC,NBRAS)
      IF (MEML .GT. 0) GO TO 6300
      IMES = 32
      IRC = 1
      GO TO 9400
6300  MEMLD4 = MEML/4
      CALL DB2219(2316,6300)
      CALL DB2231(MNAR,MEMLD4,IBACK)
      IF(IBACK .LT. 0) GO TO 9300
      CALL DB0101(NCRF,NPOS,MNAR(IBACK),0,MEML,NBRAS)
9000  IRC = 0
      GO TO 9900
9100  IRC = -2
      GO TO 9900
9300  IRC = -1
      GO TO 9900
9400  CALL DB2315(IMES,NBRAS)
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD850923--DB2317
      SUBROUTINE DB2317(IFILE,IADR,JAR,JADR,LEN,NBRAS)
      DIMENSION JAR(*),NBRAS(*)
      CALL DB0101(IFILE,IADR,JAR,JADR,LEN,NBRAS)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2318
      SUBROUTINE DB2318(IAR,MNAR,NBRAS,IRC)
      INTEGER DB2210
      DIMENSION NBRAS(*),IAR(*),MNAR(*),LINE(18)
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2206/ ICSDCB(64),ITABCB(64),ICS2CB(64)
CHP8  DATA LINE(2)/'    '/
      DATALINE(2)/Z'40404040'/
      DATA INT2/2/
      LENSTR = IAR(1)
      ICADR = 0
      IMES = 70
      IF(LENSTR .LE. 0) GO TO 8180
      IMES = 74
      IF(LENSTR .GT. 64) GO TO 8180
      NDSPL = IFLAG(16)
      JEND = 73 - LENSTR
      IF(JEND .LE. 0) GO TO 7700
      CALL DB2313(2,1,MNAR,NBRAS,ICADR,ICLEN,IRETCD)
      IRETCD = IRETCD + 3
      GO TO (8000,8100,400,8200), IRETCD
400   NCOD = ICLEN / 5
      IF(NCOD .LT. 1) GO TO 8200
      ICP = 1
      CALL DB0121(0,LINE,8,64,LEN,ITABCB,NBRAS)
      DO 5000 J = 1,NCOD
      CALL DB0121(3,LINE,8,64,LEN,ITABCB,NBRAS)
      CALL COPYCH(MNAR(ICADR),ICP,5,LINE,1)
      CALL DB0212(LINE(3),64)
      DO 800 J1 = 1,JEND
      IF(LCOMPS(IAR(INT2),1,LENSTR,LINE,J1) .EQ. 0) GO TO 2000
800   CONTINUE
      GO TO 4000
2000  IF(DB2210(1) .NE. 0) GO TO 7700
      CALL CICDC(LINE,1,72)
      WRITE(NDSPL,2100) LINE
2100  FORMAT(1X,A4,A1,1X,16A4)
4000  ICP = ICP + 5
5000  CONTINUE
7700  IRC = 1
7800  IF(ICADR .EQ. 0) GO TO 9900
      CALL DB2232(MNAR,ICADR,NRC)
      IF(NRC .EQ. 0) GO TO 9900
8000  IRC = 4
      GO TO 9900
8100  IRC = 3
      GO TO 9900
8180  CALL DB2315(IMES,NBRAS)
8200  IRC = 2
      GO TO 7800
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2321
      SUBROUTINE DB2321(IAR,NBRAS,NDPROP,MNAR,IRETC)
      DIMENSION IAR(*),NBRAS(*),NDPROP(*),MNAR(*)
      DIMENSION ITEXT(17),IPWD(2)
       INTEGER DUMI(1)
      EXTERNAL LCOMP
      COMMON /DC2201/ IFLAG(50)
CHP8  DATA INFCBD/60/, IBLANK/'    '/
      DATAINFCBD/60/,IBLANK/Z'40404040'/
      DATA INT3/3/
      IRETC = 1
      NDSPL = IFLAG(16)
      NBASES = IFLAG(24)
      IDBCB = IFLAG(40)
      IDBCB3 = IDBCB + 3
      LENDKB = MNAR(IDBCB)
      LENDKH = MNAR(IDBCB+1)
      IACTBS = MNAR(IDBCB3)
      LPROPR = MNAR(IDBCB+4)
      IF(IAR(INT3) .GT. 0) GO TO 2000
1000  IP = 1
      IF(IFLAG(37) .EQ. 0) CALL CLEAR
      DO 1200 IBAS = 1,NBASES
      CALL DB2317(NDPROP(IP+1),240,ITEXT,0,68,NBRAS)
      CALL CICDC(ITEXT,1,68)
      WRITE(NDSPL,1040) IBAS,ITEXT
1040  FORMAT(1X,I1,2X,17A4)
      CALL DB2317(NDPROP(IP+1),320,ITEXT,0,68,NBRAS)
      CALL CICDC(ITEXT,1,68)
      WRITE(NDSPL,1060) ITEXT
1060  FORMAT(4X,17A4,/,1X)
      IP = IP + LPROPR
1200  CONTINUE
      IF(IACTBS .EQ. 0) GO TO 1400
      JAN = IDBCB + LENDKH + 67
      JEND = JAN + (IACTBS-1)*LENDKB
      WRITE(NDSPL,1240) (MNAR(J),J=JAN,JEND,LENDKB)
1240  FORMAT(' DB2321 - Now active: base(s)',15I3)
1400  CALL DB2315(84,NBRAS)
      CALL DB2315(86,NBRAS)
      GO TO 9000
2000  IKBORG = IDBCB + LENDKH
      IZUSCH = 0
      MNAR(IDBCB3) = 0
      IF(IFLAG(39) .EQ. 0) GO TO 2040
      CALL DB2232(MNAR,IFLAG(39),IRK)
      IF(IRK .NE. 0) GO TO 8900
      IFLAG(39) = 0
2040  JEND = IAR(INT3) + 3
      DO 3000 JARG = 4,JEND
      IARJ = IAR(JARG)
      IF(MNAR(IDBCB3) .LT. NBASES) GO TO 2080
      WRITE(NDSPL,2060)
2060  FORMAT(' DB2321 - Warning: Too many bases requested.')
      GO TO 9000
2080  IF (JARG .EQ. 4) GO TO 2120
      J1 = JARG-1
      DO 2100 J = 4,J1
      IF (IAR(J) .EQ. IARJ) GO TO 3000
2100  CONTINUE
2120  IF (IARJ .LE. 0) GO TO 2140
      IF (IARJ .LE. NBASES) GO TO 2160
2140  CALL DB2315(94,NBRAS)
      GO TO 3000
2160  JUNK = (IARJ-1)*LPROPR
      MNAR(IKBORG+64) = NDPROP(JUNK+1)
      MNAR(IKBORG+65) = NDPROP(JUNK+2)
      MNAR(IKBORG+67) = IARJ
      MNAR(IKBORG+69) = NDPROP(JUNK+4)
      IACC = NDPROP(JUNK+3)
      MNAR(IKBORG+68) = IACC
      IF(NDPROP(JUNK+5) .EQ. IBLANK) GO TO 2180
      WRITE(NDSPL,2170) IARJ
2170  FORMAT(' Enter password for base',I3,':')
      CALL KEYBRD(IFLAG(25),IPWD,2)
      IF(IFLAG(37) .EQ. 0) CALL CLEAR
      IF(LCOMP(NDPROP(JUNK+5),IPWD,8) .EQ. 0) GO TO 2180
      WRITE(NDSPL,2175)
2175  FORMAT(' Invalid password. Base not activated')
      GO TO 3000
2180  IF(LAND(IFLAG(19),IACC) .NE. 0) GO TO 2190
      WRITE(NDSPL,2185) IARJ
2185  FORMAT(' Sorry - you are not authorized to access base',I3)
      GO TO 3000
2190  CALL DB0101(NDPROP(JUNK+2),0,MNAR(IKBORG+70),0,INFCBD*4,NBRAS)
      DO 2200 J = 1,INFCBD
      J1 = IKBORG + 69 + J
      CALL CHRINT(MNAR(J1),1,4,JT)
2200  MNAR(J1) = JT
      CALL DB0120(NDPROP(JUNK+1),NDSPL,0,MNAR(IKBORG),NBRAS)
      MEMCNT = MNAR(IKBORG+31)
      MNAR(IKBORG+130) = MEMCNT
      MNAR(IKBORG+66) = IZUSCH
      LENWO = (MEMCNT+500)/32
      MNAR(IKBORG+131) = LENWO
      IZUSCH = IZUSCH + LENWO*32
      MNAR(IDBCB3) = MNAR(IDBCB3) + 1
      IKBORG = IKBORG + LENDKB
3000  CONTINUE
      IRETC = 3
      GO TO 9000
8900  IRETC = 2
      MNAR(IDBCB3) = 0
9000  IZABR = 0
      ICB3 = MNAR(IDBCB3)
      IF(ICB3 .EQ. 0) GO TO 9200
      IPOINT = IDBCB + LENDKH + 68
      DO 9100 J = 1,ICB3
      DUMI(1) = IZABR
      IZABR = LOR(DUMI,MNAR(IPOINT))
      IPOINT = IPOINT + LENDKB
9100  CONTINUE
9200  RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2322
      SUBROUTINE DB2322(ID,LD,NBRAS,MNAR,IRETC)
      INTEGER DB2210
      DIMENSION IDSCR(8),INBUF(16),ITFULL(32),ITLEN(32),NBRAS(*),ID(*),
     1NU(16),MNAR(*),LASAV(8)
      DIMENSION LOFFT(5)
      COMMON /DC2201/ IFLAG(50)
      DATA INBMAX/64/, ITYP/0/, ITSLN/0/
      DATA LOFFT/1,1,2,3,2/, MAXTYP/5/
      DATA LENDHD/5/
      DATA MXDSKS/40/
      DATA LENUHD/2/
      DATA LDSB/11/
      IF(IFLAG(37) .EQ. 0) CALL CLEAR
20    LENSPB = LENUHD + MXDSKS*LDSB
      IVER = IFLAG(5)
      NPRINT = IFLAG(16)
      IRETC = 0
      IDBCB = IFLAG(40)
      LENDKB = MNAR(IDBCB)
      LENDKH = MNAR(IDBCB+1)
      IACTBS = MNAR(IDBCB+3)
      IBASEX = IACTBS
      NULLNR = IDBCB + LENDKH + 67 - LENDKB
      IMES = 88
      IF(IACTBS .EQ. 0) GO TO 9400
      IF(IFLAG(39) .NE. 0) GO TO 50
      CALL DB2231(MNAR,LENDHD+IACTBS*LENSPB,IDSPCH)
      IF(IDSPCH .GT. 0) GO TO 40
      IF(IDSPCH+1) 9200,9220,9220
40    IFLAG(39) = IDSPCH
50    IBSP = IDBCB + LENDKH
      MNAR(IDSPCH) = LENDHD
      MNAR(IDSPCH+1) = LENSPB
      MNAR(IDSPCH+2) = MXDSKS
      MNAR(IDSPCH+3) = LENUHD
      MNAR(IDSPCH+4) = LDSB
      IADUHD = IDSPCH + LENDHD
      DO 4000 IBAS = 1,IACTBS
      IFOUND = 0
      NXTLVL = 1
      IDSZL = 0
      INFCBA = IBSP + 70
      INFP = MNAR(INFCBA)
      INFILE = MNAR(IBSP + 65)
      IDSPXX = IADUHD + LENUHD
      IF(MNAR(INFCBA+5) .NE. 1) GO TO 100
      CALL CHRINT(ID,1,1,KLASSE)
      INFP = MNAR(INFCBA+KLASSE+19)
      IF(INFP .NE. 0) GO TO 100
      IBASEX = IBASEX - 1
      GO TO 3900
100   INFPLS = -1
      J = DB2210(0)
  200 CONTINUE
      IF(INFP .LE. INFPLS) GO TO 9010
      INFPLS = INFP
      LAD = 12
      CALL DB0101(INFILE,INFP,INBUF,0,LAD,NBRAS)
      CALL CHRINT(INBUF,1,1,ITYP)
      IF(ITYP .GT. MAXTYP) GO TO 800
      IF(ITYP .EQ. 0) GO TO 9001
      IHDR = 1
      GO TO(300,400,500,520,540),ITYP
  300 ITSLN = 1
      ITSPOS = 4
      IADD = 3
      GO TO 700
  400 CALL CHRINT(INBUF,4,1,ITSLN)
      ITSPOS = 5
      IADD = 4
      GO TO 600
  500 ITSLN = 1
      ITSPOS = 5
      IADD = 4
      GO TO 700
  520 ITSLN = 1
      ITSPOS = 6
      IADD = 5
      GO TO 700
  540 CALL CHRINT(INBUF,5,1,ITSLN)
      ITSPOS = 6
      IADD = 5
      GO TO 600
  600 IBIS = ITSPOS + ITSLN -1
      IF(IBIS .LE. LAD) GO TO 700
      IF(IBIS .GT. 64) GO TO 9003
      CALL DB0101(INFILE,INFP+LAD,INBUF,LAD,IBIS-LAD,NBRAS)
      LAD = IBIS
  700 LSTEP = IADD + ITSLN
      GO TO 1500
  800 IF(ITYP .GT. 131) GO TO 1300
      IF(ITYP .LT. 129) GO TO 9005
      ITP = ITYP - 128
      IHDR = 0
      INFQ = INFP
      CALL CHRINT(INBUF,2,1,ITSLN)
      IF(ITSLN .EQ. 0) GO TO 1000
      NACHLD = ITSLN + 7 - LAD
      IF(NACHLD .LE. 0) GO TO 1000
      IF(LAD + NACHLD .GT. INBMAX) GO TO 9006
      CALL DB0101(INFILE,INFP+LAD,INBUF,LAD,NACHLD,NBRAS)
      LAD = LAD + NACHLD
 1000 ITSPOS = 3
      LL = ITP
      CALL CHRINT(INBUF,3+ITSLN,LL,IZREF)
      INFQ = INFQ + 2 + ITSLN + LL
      INFPA = INFQ
      IF(ITP .EQ. 3) GO TO 1100
      INFQ = INFQ + 3*IZREF
      GO TO 1200
1100  CALL CHRINT(INBUF,6+ITSLN,2,LBTS)
      INFQ = INFQ + 2 + LBTS
 1200 LSTEP = INFQ - INFP
      GO TO 1500
 1300 IF(ITYP .NE. 254) GO TO 1400
      NXTLVL = LVL - 1
      IF(NXTLVL .LT. 1) GO TO 9008
      LVL = NXTLVL
      INFP = INFP + 1
      GO TO 200
 1400 IF(ITYP .NE. 255) GO TO 9009
      IBASEX = IBASEX - 1
      GO TO 3900
1500  LVL = NXTLVL
      IF(ITSLN .EQ. 0) GO TO 1520
      IPOS2 = 1
      IF(LVL .GT. 1) IPOS2 = ITFULL(LVL-1) + 1
      IF(IPOS2 + ITSLN .GT. 33) GO TO 9004
      CALL COPYCH(INBUF,ITSPOS,ITSLN,IDSCR,IPOS2)
1520  IF(LVL .GT. 1) GO TO 1540
      ITFULL(LVL) = ITSLN
      GO TO 1560
1540  ITFULL(LVL) = ITFULL(LVL-1) + ITSLN
1560  ITLEN(LVL) = ITSLN
      LGSTR = ITFULL(LVL)
      IF(IFOUND .EQ. 1) GO TO 1900
      IEHIT = 0
      LVG = MIN0(LD,LGSTR)
      IF(LVG .EQ. 0) GO TO 1800
      IF(LCOMP(ID,IDSCR,LVG)) 1700,1600,1800
1600  IF(IHDR .EQ. 0) GO TO 1640
      IF(LD - LGSTR) 1700,2500,2500
1640  IF(LD - LGSTR .GT. 0) GO TO 2500
1700  IFOUND = 1
      GO TO 1900
1800  IF(IHDR) 2500,2500,3000
1900  CONTINUE
 2000 IF(IHDR .EQ. 1) GO TO 2500
      IHMSAD = 1
      LHMSTB = 300
      IDSZL = IDSZL + 1
      MNAR(IDSPXX) = LGSTR
      MNAR(IDSPXX+1) = IZREF
      CALL COPYCH(IDSCR,1,LGSTR,MNAR(IDSPXX+2),1)
      MNAR(IDSPXX+10) = 999999
      IDSPXX = IDSPXX + LDSB
      IF(IDSZL .EQ. MXDSKS) GO TO 3900
2500  NXTLVL = LVL
      IF(IHDR .EQ. 1) NXTLVL = NXTLVL + 1
      IF(NXTLVL .GT. 32) GO TO 9002
      INFP = INFP + LSTEP
      GO TO 200
3000  NXTLVL = LVL
      LOFF = LOFFT(ITYP)
      CALL CHRINT(INBUF,2,LOFF,IOFFS)
      INFP = INFP + IOFFS
      GO TO 200
3900  MNAR(IADUHD) = IDSZL
      MNAR(IADUHD+1) = 0
      IADUHD = IADUHD + LENSPB
      IBSP = IBSP + MNAR(IDBCB)
4000  CONTINUE
      LNUMR = 0
5020  ISTHD = 0
      IADUHD = IDSPCH + LENDHD
      DO 5400 IBAS = 1,IACTBS
      IADUH1 = IADUHD + 1
      MVERBR = MNAR(IADUH1)
      NUMIBS = MNAR(IADUHD)
      IF(MVERBR .LT. NUMIBS) GO TO 5040
      IF(NUMIBS - MXDSKS) 5380,9700,9700
5040  IACA = IADUHD + LENUHD + MVERBR*LDSB
      IF(ISTHD .EQ. 0) GO TO 5240
5100  LENHI = MNAR(ISTHD)
      LENAC = MNAR(IACA)
      LAVG = MIN0(LENHI,IACA)
      IF(LCOMP(MNAR(ISTHD+2),MNAR(IACA+2),LAVG)) 5380,5200,5240
5200  IF(LENHI .LE. LENAC) GO TO 5380
5240  ISTHD = IACA
      MERKBS = IBAS
      IAVERB = IADUH1
5380  IADUHD = IADUHD + LENSPB
5400  CONTINUE
      IF(ISTHD .EQ. 0) GO TO 9800
      IF(DB2210(1) .NE. 0) GO TO 9800
      LNUMR = LNUMR + 1
      IHUND = LNUMR/100
      IEINER = MOD(LNUMR,10)
      IZEHN = MOD(LNUMR/10,10)
      LASLEN = MNAR(ISTHD)
      CALL COPYCH(MNAR(ISTHD+2),1,LASLEN,LASAV,1)
      CALL DB2207(LASAV,LASLEN,NU,NULEN,NPRINT,
     1MNAR(IHMSAD),LHMSTB)
      JUNK = MNAR(NULLNR + MERKBS*LENDKB)
      CALL CICDC(NU,1,NULEN*4)
      WRITE(NPRINT,5500) IHUND,IZEHN,IEINER,JUNK,
     1MNAR(ISTHD+1),(NU(J),J=1,NULEN)
5500  FORMAT(' L=',3I1,' Base',I2,':',I6,' * ',15A4)
      MNAR(ISTHD+10) = LNUMR
      MNAR(IAVERB) = MNAR(IAVERB) + 1
      GO TO 5020
 9001 ICD = 1
      GO TO 9100
 9002 ICD = 2
      GO TO 9100
 9003 ICD = 3
      GO TO 9100
 9004 ICD = 4
      GO TO 9100
 9005 ICD = 5
      GO TO 9100
 9006 ICD = 6
      GO TO 9100
 9008 ICD = 8
      GO TO 9100
 9009 ICD = 9
      GO TO 9100
 9010 ICD = 10
      GO TO 9100
 9100 WRITE(NPRINT,9120) INFP,ICD
 9120 FORMAT(' DB2206 - ERROR IN INV. FILE (ADDRESS=',I9,'  CODE=',I2,
     1')')
      IRETC = 1
      GO TO 9800
 9200 IRETC = 3
      GO TO 9800
 9220 IRETC = 2
      GO TO 9800
9400  CALL DB2315(IMES,NBRAS)
9700  IF (IBASEX .EQ. 0) GO TO 9800
      CALL COPYCH(LASAV,1,LASLEN,ID,1)
      LD = LASLEN
      GO TO 20
9800  CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD870120--DB2330
      SUBROUTINE DB2330(MNAR,IFSM,NFSM,IADR,NBRAS,IRC)
      COMMON /DC2201/ IFLAG(50)
      DIMENSION NBRAS(*),IFSM(*),MNAR(*)
       INTEGER I255(1)
      DIMENSION ITBREC(12), ITBFS(12)
      DIMENSION KFSR(4), KFS(4)
      DIMENSION IFELD(64)
      DIMENSION ISOF(32)
      DIMENSION NSARTB(4,10)
      INTEGER NELIST(25)
      REAL FLIST(25)
CHP8  DATA ITBFS/'R','AUT','YEAR','CODN','COL','REC','UPD','SGR',
C    1           'FORM','F','ELC','MINR'/
Cmw      DATAITBFS/Z'D9404040',Z'C1E4E340',Z'E8C5C1D9',Z'C3D6C4D5',Z'C3D6D3
Cmw     $40',Z'D9C5C340',Z'E4D7C440',Z'E2C7D940',Z'C6D6D9D4',Z'C6404040',Z'
Cmw     $C5D3C340',Z'D4C9D5D9'/
      DATAITBFS/Z'404040D9',Z'40E3E4C1',Z'D9C1C5E8',Z'D5C4D6C3',Z'40D3D6
     $C3',Z'40C3C5D9',Z'40C4D7E4',Z'40D9C7E2',Z'D4D9D6C6',Z'404040C6',Z'
     $40C3D3C5',Z'D9D5C9D4'/
      DATA ITBREC/0 ,  7  ,   6  ,   6  ,  1  ,  1  ,  1  ,  9  ,
     1              4  , 4 ,  4  ,   3  /
      DATA ITBFMX/12/, MAXIFL/256/, ISOFMX/128/, MAXSAR/ 1/, MAXKFS/4/
      DATA MXELC/25/
      DATA LENSAR/15000/, MXSRTN/ 9000/
      NFS = 0
      NDSPL = IFLAG(16)
      LNGA = 0
      NAP = 0
      CALL INTCHR(255,1,I255(1),1)
      IARFUL = 99 999 999
      LENSA4 = LENSAR*4
      IPCNT = 0
      IEND = 0
      IB2262 = 0
      KATMAX = 0
      IF(NFSM .LE. 0) GO TO 800
      DO 700 J = 1,NFSM
      IFSMJ = IFSM(J)
      DO 300 J1 = 1,ITBFMX
      IF(IFSMJ .EQ. ITBFS(J1)) GO TO 500
300   CONTINUE
      IMES = 106
      IRC = 2
      CALL CICDC(IFSMJ,1,4)
      WRITE(NDSPL,400) IFSMJ
400   FORMAT(1X,A4)
      GO TO 9200
500   IF(J1 .NE. 1) GO TO 600
      IF(NFS .GT. 0) KFSR(NFS) = 1
      GO TO 700
600   IRC = 2
      IMES = 102
      IF(NFS .EQ. MAXKFS) GO TO 9200
      NFS = NFS + 1
      KFSR(NFS) = 0
      KFS(NFS) = J1
      KATMAX = MAX0(KATMAX,ITBREC(J1))
      IF(J1.EQ.6 .OR. J1.EQ.7) IB2262 = 1
700   CONTINUE
800   IMES = 104
      IRC = 2
      IF(NFS .EQ. 0) GO TO 9200
      IDBCB = IFLAG(40)
      IACTBS = MNAR(IDBCB+3)
      IRC = 3
      IF(IACTBS .EQ. 0) GO TO 9300
      KFIRST = IDBCB + MNAR(IDBCB+1)
      LENDKB = MNAR(IDBCB)
      CALL DB2221(MNAR,IADR,1,IREL)
2000  CALL DB2221(MNAR,IADR,0,IREL)
      IF(IREL .NE. 0) GO TO 2020
      IEND = 1
      GO TO 8010
2020  JP = KFIRST
      DO 2100 JBAS = 1,IACTBS
      IZUG = MNAR(JP + 66)
      IF(IREL .LE. (IZUG + MNAR(JP+130))) GO TO 2200
      JP = JP + LENDKB
2100  CONTINUE
      GO TO 2000
2200  CALL DB2250(IREL-IZUG,IZREC,MNAR(JP),NBRAS,IRETCD)
      IF(IRETCD .NE. 0) GO TO 2000
      IF(IB2262 .NE. 1) GO TO  2220
      CALL DB2262(ISOF)
      IDREC = INVDAT(ISOF(5))
      IDUPD = INVDAT(ISOF(6))
2220  LNGB = 3*IZREC + 60
      IF(LNGB .LE. LNGA) GO TO 2500
      IF(LNGA .EQ. 0) GO TO 2400
      CALL DB2232(MNAR,ITYPAR,NRC)
      IF(NRC .NE. 0) GO TO 9800
2400  CALL DB2231(MNAR,LNGB,NRC)
      IF(NRC .LE. 0) GO TO 9100
      ITYPAR = NRC
      LNGA = LNGB
2500  CALL DB2261(MNAR(ITYPAR),LNGB,NBRAS,IRETCD,KATMAX)
      ICOL = IRETCD
      IRC = 6
      IF(IRETCD .LT. 0) GO TO 9300
      CALL INTCHR(IREL,3,ISOF,1)
      ISOFUL = 3
      DO 8000 NS = 1,NFS
      KFSNS = KFS(NS)
      LADT = ITBREC(KFSNS)
      CALL DB2252(LADT,1,MNAR(ITYPAR),NBRAS,NRC)
      IF(NRC .LE. 0) GO TO 6900
      GO TO (8000,3000,3100,3200,3300,3400,3500,3600,3700,3700,3700
     1,3900
     2), KFSNS
3000  CALL DB2256(1,IFELD,MAXIFL,LEN,NBRAS)
      IF(LEN) 6900,6900,7000
3100  CALL DB2258(1,JAHR,NERR,NBRAS)
      IF(NERR .LT. 0) GO TO 6900
      CALL INTCHR(JAHR,1,IFELD,1)
      LEN = 1
      GO TO 7000
3200  CALL DB2256(2,IFELD,7,LEN,NBRAS)
      IF(LEN) 6900,6900,7000
3300  CALL INTCHR(ICOL,3,IFELD,1)
      LEN = 3
      GO TO 7000
3400  JUNK = IDREC
      GO TO 3520
3500  JUNK = IDUPD
3520  CALL INTCHR(JUNK,3,IFELD,1)
      LEN = 3
      GO TO 7000
3600  CALL DB2256(1,IFELD,8,LEN,NBRAS)
      IF(LEN) 6900,6900,7000
3700  CALL DB2256(1,IFELD,MAXIFL,LEN,NBRAS)
      IF(LEN .LE. 0) GO TO 6900
      CALL DB2337(IFELD,LEN,NELIST,FLIST,MXELC,NELCNT)
      IF(NELCNT .LE. 0) GO TO 6900
      IF(KFSNS .EQ. 11) GO TO 3800
      LEN = 0
      DO 3740 NELE = 1,NELCNT
      CALL INTCHR(NELIST(NELE),1,IFELD,LEN+1)
      IDUM = FLIST(NELE)*1000.0 + 0.5
      CALL INTCHR(IDUM,3,IFELD,LEN+2)
      LEN = LEN + 4
3740  CONTINUE
      GO TO 7000
3800  CALL INTCHR(NELCNT,1,IFELD,1)
      LEN = 1
      GO TO 7000
3900  CALL DB2256(1,IFELD,MAXIFL,LEN,NBRAS)

      IF(LEN) 6900,6900,7000
6900  LEN = 1
      IFELD(1) = I255(1)
      IF(KFSR(NS) .EQ. 1) IFELD(1) = 0
7000  LEN = MIN0(LEN, ISOFMX-ISOFUL-NFS+NS-1)
      ISOFUL = ISOFUL + 1
      CALL INTCHR(LEN,1,ISOF,ISOFUL)
      IF(KFSR(NS) .EQ. 0) GO TO 7920
      JEND = (LEN+3) / 4
      DO 7900 J = 1,JEND
7900  IFELD(J) = LCOMPL(IFELD(J))
7920  CALL COPYCH(IFELD,1,LEN,ISOF,ISOFUL+1)
      ISOFUL = ISOFUL + LEN
8000  CONTINUE
      IF(IARFUL+ISOFUL .GT. LENSA4) GO TO 8010
      IF(IPCNT .LT. MXSRTN) GO TO 8100
8010  IF(NAP .EQ. 0) GO TO 8020
      CALL DB2234(MNAR,(IARFUL+3)/4,NSARTB(1,NAP),NRC)
      IF(NRC .LT. 0) GO TO 9800
      CALL DB2234(MNAR,IPCNT,NSARTB(2,NAP),NRC)
      IF(NRC .LT. 0) GO TO 9800
      NSARTB(3,NAP) = IPCNT
8020  IF(IEND .EQ. 1) GO TO 8300
      IRC = 2
      IMES = 108
      ISRTER = 1
      IF (NAP .EQ. MAXSAR) GO TO 9180
      NAP = NAP + 1
      DO 8040 J = 1,3
8040  NSARTB(J,NAP) = 0
      CALL DB2231(MNAR,LENSAR,NRC)
      ISRTER = 2
      IF(NRC .LE. 0) GO TO 9180
      NSARTB(1,NAP) = NRC
      IPS = NRC
      CALL DB2231(MNAR,MXSRTN,NRC)
      ISRTER = 3
      IF(NRC .LE. 0) GO TO 9180
      NSARTB(2,NAP) = NRC
      IPM1 = NRC - 1
      IARFUL = 0
      IPCNT = 0
8100  IPCNT = IPCNT + 1
      MNAR(IPM1 + IPCNT) = IARFUL+1
      CALL COPYCH(ISOF,1,ISOFUL,MNAR(IPS),IARFUL+1)
      IARFUL = IARFUL + ISOFUL
      GO TO 2000
8300  DO 8310 JSO = 1,NAP
      IPSO = NSARTB(2,JSO)
      ISOAR = NSARTB(1,JSO)
      CALL DB2331(MNAR(IPSO),NSARTB(3,JSO),NFS,3,MNAR(ISOAR))
8310  CONTINUE
      NSRCNT = 0
      DO 8320 J = 1,NAP
8320  NSRCNT = NSRCNT + NSARTB(3,J)
      CALL DB2231(MNAR,NSRCNT+4,NRC)
      IMES = 108
      ISRTER = 4
      IF(NRC + 1) 9800,9180,8340
8340  IADRSR = NRC
      CALL DB2232(MNAR,IADR,NRC)
      IF(NRC .NE. 0) GO TO 9800
      IADR = IADRSR
      IPN = NSARTB(2,1)
      IPP = IADR + 4
      NS11 = NSARTB(1,1)
      DO 8500 J1 = 1,NSRCNT
      CALL CHRINT(MNAR(NS11),MNAR(IPN),3,MNAR(IPP))
      IPN = IPN + 1
      IPP = IPP + 1
8500  CONTINUE
      MNAR(IADR) = 1
      MNAR(IADR+1) = NSRCNT
      MNAR(IADR+2) = 1
      MNAR(IADR+3) = 0
      IRC = 1
      GO TO 9300
9100  IRC = 4
      GO TO 9300
9180  WRITE(NDSPL,9190) ISRTER
9190  FORMAT(' DB2330 - Sort error #',I2)
9200  CALL DB2315(IMES,NBRAS)
9300  IF(LNGA .EQ. 0) GO TO 9320
      CALL DB2232(MNAR,ITYPAR,NRC)
      IF(NRC .NE. 0) GO TO 9800
9320  IF(NAP .EQ. 0) GO TO 9900
      DO 9340 J = 1,NAP
      DO 9330 J1 = 1,2
      J2 = NSARTB(J1,J)
      IF(J2 .EQ. 0) GO TO 9330
      CALL DB2232(MNAR,J2,NRC)
      IF(NRC .NE. 0) GO TO 9800
9330  CONTINUE
9340  CONTINUE
      GO TO 9900
9800  IRC = 5
9900  RETURN
      END
C ----------------------------------------OWNUNC411----UPD870224--DB2331
      SUBROUTINE DB2331 (IPNT,IDIM,IFLD,IOFFS,TEXT)
      INTEGER IPNT(*),TEXT(*)
  100 L = IDIM/2
  110 I = 1
  120 J = I
  130 IP1 = IPNT(J) + IOFFS
      IP2 = IPNT(J+L) + IOFFS
      DO 300 K=1,IFLD
      CALL CHRINT (TEXT,IP1,1,LEN1)
      CALL CHRINT (TEXT,IP2,1,LEN2)
      IP1 = IP1 + 1
      IP2 = IP2 + 1
      LENS = MIN0(LEN1,LEN2)
      IF (LENS .LE. 0) GOTO 250
      LC = LCOMPS (TEXT,IP1,LENS,TEXT,IP2)
      IF (LC) 500,290,400
  250 IF (LEN1-LEN2) 500,290,400
  290 IP1 = IP1 + LEN1
      IP2 = IP2 + LEN2
  300 CONTINUE
      GOTO 500
  400 K = IPNT(J)
      IPNT(J) = IPNT(J+L)
      IPNT(J+L) = K
      J = J - L
      IF (J.GT.0) GOTO 130
  500 I = I + 1
      IF (I+L.LE.IDIM) GOTO 120
      L = L/2
      IF (L.GT.0) GOTO 110
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB2333
      SUBROUTINE DB2333 (IEL,OXSTF,R,ITAB,IRC)
      DIMENSION ITAB(*)
      IRC=0
      R = 0.0
      M1=1
      CALL CHRINT (ITAB(1),1,4,M2)
      IOFFST=3*M2+2
      GO TO 30
  10  M1=M+1
  20  IF (M1-M2) 30,30,50
  30  M=(M1+M2)/2
      M3=3*M
      IF (LCOMP(IEL,ITAB(M3),2)) 40,60,10
  40  M2=M-1
      GO TO 20
  50  IRC=4
      GO TO 999
  60  CALL CHRINT (ITAB(M3+2),1,4,IPOI)
      CALL CHRINT (ITAB(M3+1),1,4,IOXMIN)
      IOXMIN=IOXMIN-10
      ISH=IPOI-IOXMIN
      CALL CHRINT (ITAB(M3+5),1,4,ITEMP)
      IOXMAX=ITEMP-ISH-1
      IF (OXSTF) 100,130,70
  70  IF (ABS(OXSTF-AINT(OXSTF+.5))-.1) 80,80,90
  80  IOX=OXSTF+.5
      GO TO 140
  90  IOX1=OXSTF
      IOX2=IOX1+1
      GO TO 180
 100  IF (ABS(OXSTF-AINT(OXSTF-.5))-.1) 110,110,120
 110  IOX=OXSTF-.5
      GO TO 140
 120  IOX1=OXSTF-1.
      IOX2=IOX1+1
      GO TO 180
 130  IOX=0
 140  IF (IOX-IOXMIN) 170,160,150
 150  IF (IOX-IOXMAX) 160,160,170
 160  CALL CHRINT (ITAB(IOX+ISH+IOFFST),1,4,ITEMP)
      R=FLOAT(ITEMP-10000)*0.001
      IF (R) 999,170,999
 170  IRC=2
      GO TO 999
 180  IF (IOX1-IOXMIN) 210,190,190
 190  IF (IOX1-IOXMAX) 200,200,170
 200  CALL CHRINT (ITAB(IOX1+ISH+IOFFST),1,4,ITEMP)
      R1=FLOAT(ITEMP-10000)*0.001
      IF (R1) 220,210,220
 210  IRC=1
 220  IF (IOX2-IOXMIN) 170,230,230
 230  IF (IOX2-IOXMAX) 260,260,240
 240  IF (IRC) 170,250,170
 250  R=R1
      GO TO 999
 260  CALL CHRINT (ITAB(IOX2+ISH+IOFFST),1,4,ITEMP)
      R2=FLOAT(ITEMP-10000)*0.001
      IF (R2) 270,240,270
 270  IF (IRC) 280,290,280
 280  R=R2
      IRC=1
      GO TO 999
 290  A=(R2-R1)/FLOAT(IOX2-IOX1)
      B=R2-A*FLOAT(IOX2)
      R=A*OXSTF+B
 999  RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--DB2334
      SUBROUTINE DB2334 (ITMBUF, SYM,NSYM,NBGTYP, MNAR,IAR,NBRAS,IRC)
      DIMENSION ITMBUF(3),SYM(12,*),IAR(*),NBRAS(*),MNAR(*),IBGTYP(2)
       DIMENSION IAIN(9),LCHAR(1)
      DIMENSION ITNBUF(2)
      COMMON /DC2201/ IFLAG(50)
CHP8  DATA IBGTYP/'PFAB','CIRH'/,LCHAR(1)/','/,IHXBLK/'    '/
Cmw      DATAIBGTYP/Z'D7C6C1C2',Z'C3C9D9C8'/,LCHAR(1)/Z'6B404040'/,IHXBLK/Z
Cmw     $'40404040'/
      DATAIBGTYP/Z'C2C1C6D7',Z'C8D9C9C3'/,LCHAR(1)/Z'4040406B'/,IHXBLK/Z
     $'40404040'/
CHP8  DATA IRC2/0/,IPRGIT/'P?  '/
Cmw      DATAIRC2/0/,IPRGIT/Z'D76F4040'/
      DATAIRC2/0/,IPRGIT/Z'40406FD7'/
      NTOUT=IFLAG(33)
      NTDSPL=IFLAG(16)
      IVERFY=1
      IF (IFLAG(29)) 1,2,1
    1 IVERFY=0
    2 IRC=0
      ITMBUF(1)=IPRGIT
      ITMBUF(2)=IHXBLK
      CALL CICDCS (ITMBUF,1,8, ITNBUF)
      ITMBUF(3)=0
      IZNFLG=-1
      CALL DB2252 (9,1,IAR,NBRAS,NRC)
      IF (NRC) 160,160,10
   10 CALL DB2256 (1,ITMBUF,8,LEN,NBRAS)
      CALL CICDCS (ITMBUF,1,8, ITNBUF)
      IF (LEN) 160,160,20
   20 IF (IFLAG(36)-1) 40,30,40
   30 CALL DB2258 (3,IZNFLG,NRC,NBRAS)
      GO TO 160
   40 CALL DB2292 (MNAR,NBRAS,ITMBUF,0,SYM,NSYM,48,NBGTYP,IRC2)
      IF (IRC2) 160,999,50
   50 IF (IRC2-3) 160,160,70
   70 WRITE (NTDSPL,80) IRC2,IFLAG(20)
   80 FORMAT (' DB2334 - RC from DB2292 =',I3,' (COL',I7,')')
      GO TO 990
   90 IF (IRC2-3) 100,130,70
  100 CONTINUE
      WRITE (NTDSPL,120) ITNBUF(1),ITNBUF(2),IFLAG(20)
  120 FORMAT (' DB2334 - Space group symbol ',2A4,' not found. (COL',I7,
     1')')
      GO TO 990
  130 CONTINUE
      WRITE (NTDSPL,150) ITNBUF(1),ITNBUF(2),IFLAG(20)
  150 FORMAT (' DB2334 - Space-group ',2A4,' not unique.  (COL',I7,')')
      GO TO 990
  160 NSYM=0
      CALL DB2252 (10,1,IAR,NBRAS,NRC)
      IF (NRC) 170,170,190
  170 WRITE (NTDSPL,180) IFLAG(20)
  180 FORMAT (' DB2334 - Missing symmetries.  (COL',I7,')')
      GO TO 90
  190 DO 200 I=1,7
      IF (LCOMPS(ITMBUF,1,1, IBGTYP,I)) 200,220,200
  200 CONTINUE
      IF (IVERFY) 210,990,210
  210 IMSGNR=52
      GO TO 990
  220 NBGTYP=I-1
      I=1
      IF (NBGTYP .NE. 6) GO TO 340
      J=9
  230 J=J-1
      IF (LCOMPS(ITMBUF,J,1, IHXBLK,1)) 240,230,240
  240 IF (LCOMPS(ITMBUF,J,1, IBGTYP,8)) 260,250,260
  250 NBGTYP=7
      GO TO 340
  260 IF (LCOMPS(ITMBUF,J,1, IBGTYP,7)) 270,280,270
  270 NBGTYP=0
      GO TO 340
  280 IF (LCOMPS(ITMBUF,J-1,1, IBGTYP,8)) 270,290,270
  290 NBGTYP=8
      GO TO 340
  300 NSYM=NSYM+1
      CALL DB2293 (SYM(1,NSYM),IAIN,36,IRC2)
      IF (IRC2) 310,330,310
  310 IF (IVERFY) 320,990,320
  320 IMSGNR=54
      GO TO 990
  330 I=I+1
      CALL DB2252 (10,I,IAR,NBRAS,NRC)
      IF (NRC) 390,390,340
  340 DO 350 J=1,9
  350 IAIN(J)=IHXBLK
      J=1
      JPOI=0
      GO TO 370
  360 JPOI=JPOI+1
      CALL COPYCH (LCHAR(1),1,1, IAIN,JPOI)
  370 JPOI=JPOI+1
      CALL DB2256 (J,ITMBUF,12,LEN,NBRAS)
      IF (LEN) 300,300,380
  380 CALL COPYCH (ITMBUF,1,LEN, IAIN,JPOI)
      JPOI=JPOI+LEN
      J=J+1
      IF (J-3) 360,360,300
  390 IF (NSYM) 990,990,400
  400 IRC2=0
      IF (IZNFLG-2) 999,410,990
  410 IF (2*NSYM-48) 440,440,420
  420 WRITE (NTDSPL,430) IFLAG(20)
  430 FORMAT (' DB2334 - Too many symmetries.  (COL',I7,')')
      GO TO 990
  440 CALL DB2298 (SYM,NSYM,1)
      GO TO 999
  990 IRC=-2
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD861217--DB2335
      SUBROUTINE DB2335(NTIN,NTDSPL,IFILE)
C
C ---ADAPTATION TEST PROGRAM OF THE CRYSTIN SYSTEM.
C
      INTEGER L(760),CODE,IH(8),ISTR(4),IB(14),ICCONV(32)
      INTEGER COMTYP(12,3)
C
      COMMON /DC2201/ IFLAG(50)
      COMMON /DC2227/ IBTMAX,IBITT(64)
      COMMON /DC0100/ NREC,NFLAG,NSEQ,NFILE,NTEXT,NSF,NSFPNT,
     2       NBLSIZ,NWORDS,MAXBLK,NPRINT,NVERFY,NBUFST,
     3       IOPEN,IWRITE,
     4       NPCNT,ISTOPF,NRDCNT,NWRCNT
C
      DATA IREC/601/,ICOMAX/3/
      DATA IARG1/0/
       DATA ISTR/4HABCD,4HEFGH,4H1234,4H5678/
      DATA ICCONV/-4,-4,-1,-1,0,1,2,3,4,5,6,7,8,9,-1,-1,
     1     -4,-4,-4,-4,-4,-4,-3,-4,-4,-4,-2,-4,-4,-1,-1,-1/
      DATA COMTYP/-1,16711935,-267387136,0,268435456,33554432,48,4,
     1     1515870810,-1515870811,1431677610,-1437226496,
     2     -1,-16711936,16715760,0,16,2,805306368,67108864,
     3     1515870810,-1515870811,-1431677611,11163050,
     4     2147483647,8355967,2013790080,0,134217728,16777216,24,2,
     5     757935405,1389548242,715838805,1428870400/
C
C ---CLEAR THE VERIFY FLAG AND SOME COUNTS (USED IN DB0106)
      NVERFY = 0
      NPCNT = 0
      NWRCNT = 0
C
C ---GET THE RECORD CONTANING TEST DATA
      CALL DB0106(IFILE,IDUM,IREC,L,760)
C
C ---FIND OUT THE COMPUTER TYPE
      CODE = 5
      DO 100 J = 1,ICOMAX
      DO  80 J1 = 1,8
      LJ1 = L(J1)
      IF(J .EQ. 3) LJ1 = LJ1 / 2
      IF(LJ1 .NE. COMTYP(J1,J)) GO TO 100
80    CONTINUE
      DO  90 J1 = 757,760
      LJ1 = L(J1)
      IF(J .EQ. 3) LJ1 = LJ1 / 2
      IF(LJ1 .NE. COMTYP(J1-748,J)) GO TO 100
90    CONTINUE
      WRITE(NTDSPL,95) J
95    FORMAT(' DB2335 - COMPUTER TYPE',I3)
      GO TO 120
100   CONTINUE
C ---BAD DATA APPORTED BY DB0106!
      GO TO 9000
C
C ---TEST THE "AND", "OR" AND "ONE'S COMPLEMENT" FUNCTIONS
120   CODE = 10
      IF(LAND(L(9),L(10)) .NE. L(13)) GO TO 9000
      CODE = 20
      IF(LAND(L(11),L(12)) .NE. L(14)) GO TO 9000
      CODE = 30
      IF(LOR(L(9),L(10)) .NE. L(15)) GO TO 9000
      CODE = 40
      IF(LOR(L(11),L(12)) .NE. L(16)) GO TO 9000
      CODE = 50
      IF(LCOMPL(L(9)) .NE. L(17)) GO TO 9000
      CODE = 60
      IF(LCOMPL(L(10)) .NE. L(18)) GO TO 9000
C
C ---TEST THE COPY ROUTINE
      CODE = 70
      CALL COPYCH(L(19),1,4,IH,1)
      IF(L(19) .NE. IH(1)) GO TO 9000
C
      DO 200 J = 1,8
200   IH(J) = L(25)
      CODE = 80
      CALL COPYCH(L,74,1,IH(1),4)
      IF(IH(1) .NE. L(26)) GO TO 9000
C
      CODE = 90
      CALL COPYCH(L(19),6,15,IH(2),8)
      DO 240 J = 1,7
      IF(IH(J+1) .NE. L(J+26)) GO TO 9000
240   CONTINUE
C
C ---TEST CICDC AND CICDCS. THESE ROUTINES CONVERT STRINGS WHICH
C     ARE TO BE OUTPUT USING THE "A-FORMAT".
      DO 300 J = 1,4
300   IH(J) = L(J+18)
      CODE = 100
      CALL CICDC(IH,1,16)
      DO 320 J = 1,4
      IF(IH(J) .NE. ISTR(J)) GO TO 9000
320   CONTINUE
C
      CODE = 110
      CALL CICDCS(L(19),1,16,IH)
      DO 340 J = 1,4
      IF(IH(J) .NE. ISTR(J)) GO TO 9000
340   CONTINUE
C
C ---TEST THE COMPARE FUNCTIONS
      CODE = 120
      IF(LCOMP(L(19),L(34),7) .NE. 0) GO TO 9000
      CODE = 130
      IARG1 = LCOMP(L(19),L(34),12)
      IF(IARG1 .NE. 1) GO TO 9000
      CODE = 140
      IF(LCOMP(L(34),L(21),1) .NE. -1) GO TO 9000
      CODE = 150
      IF(LCOMPS(L(19),6,14,L(28),4) .NE. 0) GO TO 9000
      CODE = 160
      IF(LCOMPS(L(18),10,16,L(28),4) .NE. 1) GO TO 9000
      CODE = 170
      IF(LCOMPS(L(28),4,16,L(18),10) .NE. -1) GO TO 9000
C
C ---TEST THE SMALL-UPPERCASE CONVERSION
      CODE = 180
      DO 400 J = 1,14
400   IB(J) = L(J+36)
      CALL DB0212(IB,56)
      IF(LCOMP(IB,L(51),56) .NE. 0) GO TO 9000
C
C ---TEST CHARACTER-TO-INTEGER AND INTEGER-TO-CHARACTER CONVERSION
      CODE = 190
      CALL CHRINT(L(65),2,1,N)
      IF(N .NE. 35) GO TO 9000
      CODE = 200
      CALL INTCHR(N,1,IH,2)
      IF(LCOMPS(IH,2,1,L(65),2) .NE. 0) GO TO 9000
      CODE = 210
      CALL CHRINT(L(65),2,2,N)
      IF(N .NE. 9029) GO TO 9000
      CODE = 220
      CALL INTCHR(N,2,IH,2)
      IF(LCOMPS(IH,2,2,L(65),2) .NE. 0) GO TO 9000
      CODE = 230
      CALL CHRINT(L(65),2,3,N)
      IF(N .NE. 2311527) GO TO 9000
      CODE = 240
      CALL INTCHR(N,3,IH,2)
      IF(LCOMPS(IH,2,3,L(65),2) .NE. 0) GO TO 9000
      CODE = 250
      CALL CHRINT(L(65),2,4,N)
      IF(N .NE. 591751049) GO TO 9000
      CODE = 260
      CALL INTCHR(N,4,IH,2)
      IF(LCOMPS(IH,2,4,L(65),2) .NE. 0) GO TO 9000
C
C ---GENERATE AND TEST THE BIT MASKS IN COMMON BLOCK /DC2227/
      CODE = 265
      CALL DB2227
      DO 420 J = 1,64
      IARG1 = J
      IF(IBITT(J) .NE. L(J+71)) GO TO 9000
420   CONTINUE
C
C ---TEST CONVCI (= CONVERT NUMERIC CHRACTER TO INTEGER)
      CODE = 270
      DO 440 J = 1,32
      CALL CONVCI(L(57),J,IZIF)
      IF(IZIF .NE. ICCONV(J)) GO TO 9000
440   CONTINUE
C
C ---TEST THE KEYBOARD INPUT PROGRAM.
      IF(NTIN .LE. 0) GO TO 540
      CODE = 280
      WRITE(NTDSPL,500)
500   FORMAT(' KEYBOARD TEST. ENTER SOME CHARACTERS, PLEASE:')
      CALL KEYBRD(NTIN,IB,14)
      CALL CICDC(IB,1,56)
      WRITE(NTDSPL,520) IB
520   FORMAT(1X,14A4)
C
540   CONTINUE
C
C ---TEST THE AUTHORITY CODE. USER MUST BE AUTHORIZED TO ACCESS
C     AT LEAST ONE DATABASE.
560   CODE = 300
      IARG1 = IFLAG(19)
      IF(IARG1 .LE. 0) GO TO 9000
      IF(IARG1 .GT. 65535) GO TO 9000
C
C ---NO ERRORS FOUND
8000  CODE = 1000
C
9000  IF(CODE .LT. 1000) WRITE(NTDSPL,9020) CODE,IARG1
9020  FORMAT(' DB2335 - WARNING: CRYSTIN IS NOT PROPERLY ADAPTED.',/,
     1' CODE=',I4,' IARG1=',I12)
C
      IF(CODE .LT. 1000) WRITE(NTDSPL,9060) IFILE,IREC
9060  FORMAT(' CONTENTS OF FILE',I3,', RECORD',I5,
     1' (WORDS 1...8 AND 757...760):')
      IF(CODE .LT. 1000) WRITE(NTDSPL,9080) (L(J),J=1,8),
     1(L(J),J=757,760)
9080  FORMAT(1X,4I17)
C
      IF(NTIN.GT.0 .AND. CODE.EQ.1000) WRITE(NTDSPL,9500)
9500  FORMAT(' NO ADAPTATION ERRORS DETECTED.')
      IF(NTIN.LE.0 .AND. CODE.EQ.1000) WRITE(NTDSPL,9540)
9540  FORMAT(1X,70('-'),/,
     1' MESSAGE TO THE SYSTEM PROGRAMMER: THE ADAPTATION TEST',
     2' FACILITY',/,
     3' SHOULD NOW BE REMOVED BY DELETING THE PROGRAM DB2335 AND',/,
     4' THE TRANSFERS "CALL DB2335" IN THE MAIN PROGRAM AND IN DB2201',
     5/,1X,70('-'))
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD870107--DB2337
      SUBROUTINE DB2337 (INSTR,INLEN,NELIST,FLIST,NEMAX,NELCNT)
      COMMON /DC2011/ NELE  (106),IREFPT(107),MNEMO(35),IREF(392)
      COMMON /DC2337/ IELORD(20),MXLORD,IELOFL
       INTEGER NN0(1),NBXX(1),NEL4XX(1),IBLXX(1),IDMXX(1),NC2(1)
       INTEGER NC1(1)
      REAL FAK(20),FLIST(NEMAX)
      INTEGER INSTR(*)
      DIMENSION NELIST(NEMAX)
      INTEGER LPAR,RPAR,PERIOD,BLANK,LISTE(10)
      EQUIVALENCE (NB,NBXX(1)),(NEL4,NEL4XX(1))
CHP8  DATA NB/' '/,LPAR/'('/,RPAR/')'/,PERIOD/'.'/,LBL/' '/,
C    2   BLANK/' '/,NNA/'A'/,NNZ/'Z'/,NN0/'0'/,NN9/'9'/,NEL4/' '/,
C    3   NC1/0/,NC2/0/
Cmw      DATANB/Z'40404040'/,LPAR/Z'4D404040'/,RPAR/Z'5D404040'/,PERIOD/Z'4
Cmw     $B404040'/,LBL/Z'40404040'/,BLANK/Z'40404040'/,NNA/Z'C1404040'/,NNZ
Cmw     $/Z'E9404040'/,NN0/Z'F0404040'/,NN9/Z'F9404040'/,NEL4/Z'40404040'/,
Cmw     $NC1/0/,NC2/0/
      DATANB/Z'40404040'/,LPAR/Z'4040404D'/,RPAR/Z'4040405D'/,PERIOD/Z'4
     $040404B'/,LBL/Z'40404040'/,BLANK/Z'40404040'/,NNA/Z'404040C1'/,NNZ
     $/Z'404040E9'/,NN0/Z'404040F0'/,NN9/Z'404040F9'/,NEL4/Z'40404040'/,
     $NC1/0/,NC2/0/
CHP8  DATA IBLXX(1)/'    '/, IDMXX/'    '/
      DATAIBLXX(1)/Z'40404040'/,IDMXX/Z'40404040'/
      DATA NELDEF/106/, NZ/0/
      NELCNT = 0
      F = 1.0
      IENDFL = 0
      ILPAR = 0
      IRPAR = 0
      IDIG = 0
      IELE = 0
      IDEZPT = 0
      ISTP = 0
      IPNT = INLEN + 1
      CALL COPYCH (NN0,1,1,NC2,4)
  100 IPNT = IPNT - 1
      IF (IPNT.LT.1) GOTO 7000
      CALL COPYCH(INSTR,IPNT,1,NBXX,1)
      CALL CHRINT(INSTR,IPNT,1,NZ)
      IF(NZ .GE. 129) GO TO 200
      IF(NZ .EQ. 64) GO TO 5000
      IF(NZ .EQ. 77) GO TO 3000
      IF(NZ .EQ. 93) GO TO 4000
      IF(NZ - 75) 9902,4500,9902
200   IF(NZ.LE.233 .AND. NZ.GE.193) GO TO 2000
      IF(NZ.LE.249 .AND. NZ.GE.240) GO TO 1000
      IF(NZ.GT.169 .OR.  NZ.LT.129) GO TO 9902
      CALL DB0212(NBXX,1)
      GO TO 2000
 1000 IF (IDIG.GT.0) GOTO 1100
      IF (IELE.GT.0.OR.ILPAR.GT.0) GOTO 9901
      IF (IDEZPT.LE.0) F = 0.0
 1100 F = F + FLOAT(NZ - 240     )*10.**(IDIG-IDEZPT)
      IDIG = IDIG + 1
      IRPAR = 0
      GOTO 100
 2000 IF (ILPAR.GT.0) GOTO 9901
      IRPAR = 0
      IDIG = 0
      IDEZPT = 0
      IELE = IELE + 1
      GOTO (2020,2030,9903),IELE
 2020 CALL COPYCH(NBXX,1,1,NEL4XX,1)
      CALL COPYCH(IBLXX,1,1,NEL4XX,2)
      GOTO 100
 2030 CALL COPYCH (NEL4XX,1,1,IDMXX,1)
      CALL COPYCH (IDMXX,1,1,NEL4XX,2)
      CALL COPYCH(NBXX,1,1,NEL4XX,1)
      GOTO 100
 3000 IF (IDIG.GT.0.OR.IRPAR.GT.0) GOTO 9901
      ILPAR = 1
      IF (IELE.GT.0) GOTO 6000
 3010 ISTP = ISTP - 1
      IF (ISTP.LT.0) GOTO 9904
      GOTO 100
 4000 IF (IELE.GT.0.OR.ILPAR.GT.0) GOTO 9901
      IDIG = 0
      IDEZPT = 0
      IRPAR = 1
      ISTP = ISTP + 1
      IF (ISTP.GT.NEMAX) GOTO 9904
      FAK(ISTP) = F
      F = 1.0
      GOTO 100
 4500 IF (IDEZPT.GT.0) GOTO 9905
      F = F*10.**(-IDIG)
      IDIG = IDIG + 1
      IDEZPT = IDIG
      GOTO 100
 5000 IF (IDIG.GT.0) GOTO 9901
      ILPAR = 0
      IF (IELE.LT.1) GOTO 100
 6000 CALL DB2012(NEL4XX,LENE,LISTE)
      IF (LENE. LE. 0) GO TO 9903
      NR = LISTE(1)
      FTOT = F
      IF (ISTP.LE.0) GOTO 6050
      DO 6020 I=1,ISTP
 6020 FTOT = FTOT * FAK(I)
 6050 IF (NELCNT.LE.0) GOTO 6100
      DO 6070 I=1,NELCNT
      IF (NR.NE.NELIST(I)) GOTO 6070
      FLIST(I) = FLIST(I) + FTOT
      GOTO 6150
 6070 CONTINUE
 6100 NELCNT = NELCNT + 1
      IF(NELCNT .GT. NEMAX) GO TO 9906
      FLIST(NELCNT) = FTOT
      NELIST(NELCNT) = NR
 6150 F = 1.0
      IELE = 0
      IF (ILPAR.GT.0) GOTO 3010
      IF (IENDFL.LE.0) GOTO 100
 7000 IENDFL = 1
      IF (ISTP.NE.0) GOTO 9904
      IF (IELE.GT.0) GOTO 6000
      IF (NELCNT .LE. 0) GO TO 9999
      JBEG = 1
      IF(IELOFL .LE. 0) GO TO 7040
      DO 7030 JL = 1,IELOFL
      DO 7010 JA = JBEG,NELCNT
      IF(NELIST(JA) .EQ. IELORD(JL)) GO TO 7020
7010  CONTINUE
      GO TO 7030
7020  NESAV = NELIST(JA)
      NELIST(JA) = NELIST(JBEG)
      NELIST(JBEG) = NESAV
      FSAV = FLIST(JA)
      FLIST(JA) = FLIST(JBEG)
      FLIST(JBEG) = FSAV
      JBEG = JBEG + 1
      IF(JBEG .EQ. NELCNT) GO TO 9999
7030  CONTINUE
7040  JEND = NELCNT - 1
      DO 7100 JA = JBEG,JEND
      KLEIN = 999
      DO 7060 JI = JA,NELCNT
      IF (NELIST(JI) .GE. KLEIN) GO TO 7060
      KLEIN = NELIST(JI)
      KLEINP = JI
7060  CONTINUE
      FSAV = FLIST(KLEINP)
      FLIST(KLEINP) = FLIST(JA)
      FLIST(JA) = FSAV
      NESAV = NELIST(KLEINP)
      NELIST(KLEINP) = NELIST(JA)
      NELIST(JA) = NESAV
7100  CONTINUE
      GO TO 9999
 9901 NELCNT = -1
      GO TO 9999
 9902 NELCNT = -2
      GO TO 9999
 9903 NELCNT = -3
      GO TO 9999
 9904 NELCNT = -4
      GO TO 9999
 9905 NELCNT = -5
      GO TO 9999
 9906 NELCNT = -6
 9999 CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD860523--DB2338
      SUBROUTINE DB2338(IPORT,IRC)
      COMMON /DC2201/ IFLAG(50)
      IRC = 0
      IF (IPORT .LT. IFLAG(45)) GO TO 100
      IF (IPORT .LE. IFLAG(46)) GO TO 999
100   IF (IPORT .EQ. IFLAG(16)) GO TO 999
      IF (IPORT .EQ. IFLAG(27)) GO TO 999
      NDSPL = IFLAG(16)
      WRITE(NDSPL,200) IPORT,IFLAG(45),IFLAG(46)
200   FORMAT(' DB2338 - Unit=',I4,' is invalid.',
     1' Please use',I3,'...',I2,'.')
      IRC = 1
999   RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--DB9999
      SUBROUTINE DB9999 (NPRINT,NPROGR,NCODE)
      WRITE (NPRINT,1000) NPROGR,NCODE
 1000 FORMAT (' SYSTEM ERROR IN PROGRAM NR.',I6,', REASON-CODE = ',I4/
     2  '0  G N O T H I  S E A U T O N !')
      CALL TERMIC
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--EBCA
C
C     HP-UX-VERSION
C
      SUBROUTINE EBCA  (ISTR  ,ISTRT,LEN)
C
C ---CONVERT A STRING FROM EBCDIC TO ASCII
C
C     ISTR   - IN THE CALLING PROGRAM: INTEGER*4 ARRAY
C     ISTRT  - FIRST CHARACTER TO BE CONVERTED (NOTE: EACH ELEMENT
C              OF THE INTEGER*4 ARRAY CONTAINS 4 CHARACTERS!)
C     LEN    - NUMBER OF CHARACTERS TO BE CONVERTED
C
      character*1 ISTRNG(1), LTABL(256), LP(4), cwort(4)
      INTEGER*4 ITABL(64),istr(*)
      EQUIVALENCE (ITABL(1),LTABL(1)), (IP,LP(1))
      equivalence (istrng(1),nstrng)
      equivalence (cwort(1),iwort)
c
      DATA IP/0/
Cmw       DATA ITABL /Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
Cmw     1            Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
Cmw     2            Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
Cmw     3            Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
Cmw     4            Z'203F3F3F',Z'3F3F3F3F',Z'3F3F3F2E',Z'3C282B7C',
Cmw     5            Z'263F3F3F',Z'3F3F3F3F',Z'3F3F2124',Z'2A293B3F',
Cmw     6            Z'2D2F3F3F',Z'3F3F3F3F',Z'3F3F3F2C',Z'253F3E3F',
Cmw     7            Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3A23',Z'40273D22',
Cmw     8            Z'3F616263',Z'64656667',Z'68693F3F',Z'3F3F3F3F',
Cmw     9            Z'3F6A6B6C',Z'6D6E6F70',Z'71723F3F',Z'3F3F3F3F',
Cmw     A            Z'3F3F7374',Z'75767778',Z'797A3F3F',Z'3F3F3F3F',
Cmw     B            Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
Cmw     C            Z'3F414243',Z'44454647',Z'48493F3F',Z'3F3F3F3F',
Cmw     D            Z'3F4A4B4C',Z'4D4E4F50',Z'51523F3F',Z'3F3F3F3F',
Cmw     E            Z'3F3F5354',Z'55565758',Z'595A3F3F',Z'3F3F3F3F',
Cmw     F            Z'30313233',Z'34353637',Z'38393F3F',Z'3F3F3F3F'/
       DATA ITABL /Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
     1            Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
     2            Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
     3            Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
     4            Z'3F3F3F20',Z'3F3F3F3F',Z'2E3F3F3F',Z'7C2B283C',
     5            Z'3F3F3F26',Z'3F3F3F3F',Z'24213F3F',Z'3F3B292A',
     6            Z'3F3F2F2D',Z'3F3F3F3F',Z'2C3F3F3F',Z'3F3E3F25',
     7            Z'3F3F3F3F',Z'3F3F3F3F',Z'233A3F33',Z'223D2740',
     8            Z'6362613F',Z'67666564',Z'3F3F6968',Z'3F3F3F3F',
     9            Z'6C6B6A3F',Z'706F6E6D',Z'3F3F7271',Z'3F3F3F3F',
     A            Z'74733F3F',Z'78777675',Z'3F3F7A79',Z'3F3F3F3F',
     B            Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',Z'3F3F3F3F',
     C            Z'4342413F',Z'47464544',Z'3F3F4948',Z'3F3F3F3F',
     D            Z'4C4B4A3F',Z'504F4E4D',Z'3F3F5251',Z'3F3F3F3F',
     E            Z'54533F3F',Z'58575655',Z'3F3F5A59',Z'3F3F3F3F',
     F            Z'33323130',Z'37363534',Z'3F3F3938',Z'3F3F3F3F'/
c
c----Adresse des ersten 4-Byte-Wortes
      iad4 = (istrt + 3)/4
c
c----dieses Wort herauskopieren
      iwort =  istr(iad4)
c
c----Byte-Nummer im herauskopierten Wort
      iad1 = istrt + 4 - 4*iad4
c
      DO 20 J = 1,len
c----adressiertes Byte nach rechts shiften
      ip = 0
Cmw      lp(4) = cwort(iad1)
      lp(1) = cwort(iad1)
      cwort(iad1) = LTABL(ip+1)
      istr(iad4) = iwort
c
      if (iad1 .ge. 4) then
         IAD1 = 1
         istr(iad4) = iwort
         IAD4 = IAD4 + 1
         IWORT = ISTR(IAD4)
      else
         IAD1 = IAD1 + 1
      end if
20    continue
c
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD860128--ETRACE
      SUBROUTINE ETRACE
C
C ---THIS PROGRAM FORCES AN "ERROR TRACE".
C
      DATA N/0/,J/0/
      I=N/J
      CALL TERMIC
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880524--INTCHR
C
C
C  ******************************************************
C  *                                                    *
C  *                   ========                         *
C  *  THIS PROGRAM IS  = SLOW =                         *
C  *                   ========                         *
C  *                              ========              *
C  *  IT SHOULD BE REPLACED BY A  = FAST =  PROGRAM AS  *
C  *  SOON AS POSSIBLE.           ========              *
C  *                                                    *
C  ******************************************************
C
C
C
      SUBROUTINE INTCHR (N,LEN,ISTRNG,ISTRT)
      DIMENSION ISTRNG(*)
Cmw      CALL COPYCH(N,5-LEN,LEN,ISTRNG,ISTRT)
      DO 3999 I=1,LEN
         CALL COPYCH(N,I,1,ISTRNG,ISTRT+LEN-I)
3999  CONTINUE
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD850903--INVDAT
      FUNCTION INVDAT (I)
      I1 = I/10000
      I3 = I/100
      N = 100*I3
      I3 = I - N
      INVDAT = N - 10000*I1 + I1 + 10000*I3
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--KEYBRD
      SUBROUTINE KEYBRD(KB,LINE,IWRDS)
      INTEGER LINE(*),HLINE(20)
      CHARACTER*80 CLINE
      character*1 HHH
      CHARACTER*1 NULL
      EQUIVALENCE (HLINE(1),CLINE)
C
Ccuw  DATA NULL/Z'00'/
      DATA NULL/Z'00'/          !use with UNIX compilers AWH
c     DATA NULL/CHAR(0)/
c      parameter(HHH=CHAR(0))   !Use with MS-Fortran AWH
c      DATA NULL/HHH/                   !Use with MS-Fortran AWH
CC
CC---KB < 0 : SUPPRESS CONVERSION TO UPPERCASE
      KBRD = IABS(KB)
CC
      READ(KBRD,120,END=125) CLINE
120   FORMAT(A)
      IDX = INDEX(CLINE,NULL)
      GO TO 130
125   REWIND 5
      IDX = 1
      STOP                                      !don't mess around looping endlessly AWH
130   IF(IDX .GT. 0) CLINE(IDX:80) = ' '
      DO 140 J = 1,IWRDS
140   LINE(J) = HLINE(J)
      CALL ASCE (LINE,1,4*IWRDS)
C     WRITE(60,101) (LINE(J),J=1,IWRDS)
 101  FORMAT(20A4)
C
CC---CONVERT THE ENTIRE INPUT TO CAPITALS (ONLY IF KB >= 0)
      IF (KB .GE. 0) CALL DB0212(LINE,4*IWRDS)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880524--LAND
C
C   *****************************************************
C   * IT IS RECOMMENDED TO REPLACE THIS PROGRAM BY A    *
C   * FAST MACHINE ROUTINE.                             *
C   *****************************************************
C
      INTEGER FUNCTION LAND (ARG1,ARG2)
      INTEGER*4 ARG1,ARG2
      LAND = IAND(ARG1,ARG2)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880524--LCOMP
C
C   *****************************************************
C   * IT IS RECOMMENDED TO REPLACE THIS FUNCTION BY A   *
C   * FAST MACHINE ROUTINE.                             *
C   *****************************************************
C
      INTEGER FUNCTION LCOMP(A,B,LEN)
      INTEGER A(*), B(*)
C
      A(1) = A(1)
      B(1) = B(1)
c      LEN = LEN                        !AWH 20/10/97 Solaris attempt to modify constant
      LCOMP = LCOMPS(A,1,LEN,B,1)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880524--LCOMPL
C
C   THIS FUNCTION IS CALLED IN THE FOLLOWING WAY:
C     I = LCOMPL(J)
C   I IS THE ONE'S COMPLEMENT OF J (I.E. EVERY BIT IN THE WORD J IS
C   INVERTED).
C
      FUNCTION LCOMPL (IARG1)
      LCOMPL=NOT(IARG1)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880524--LCOMPS
C
C   *****************************************************
C   * THIS PROGRAM SHOULD BE REPLACED BY A FAST MACHINE *
C   * ROUTINE IF POSSIBLE.                              *
C   *****************************************************
C
c      FUNCTION LCOMPS (STR1,ADR1,LEN,STR2,ADR2)
      INTEGER FUNCTION LCOMPS (STR1,ADR1,LEN,STR2,ADR2)         !AWH 20/10/97
      INTEGER*4 STR1(*),STR2(*),ADR1,ADR2,LEN
      DATA NULL/0/
C
      IF (LEN) 10,10,30
   10 CONTINUE
      WRITE (6,20)
   20 FORMAT (' ***** LCOMPS LEN <= 0 *****')
CC---FORCE AN ERROR TRACE
      NULL=NULL/NULL
      GO TO 999
C
   30 J=ADR1
      K=ADR2
      DO 50 I=1,LEN
      CALL CHRINT (STR1,J,1, IH)
      CALL CHRINT (STR2,K,1, IK)
      IF (IH-IK) 80,40,70
   40 J=J+1
      K=K+1
   50 CONTINUE
   60 LCOMPS=0
      GO TO 999
C
   70 LCOMPS=1
      GO TO 999
C
   80 LCOMPS=-1
C
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880524--LOR
C
C   *****************************************************
C   * THIS PROGRAM SHOULD BE REPLACED BY A FAST MACHINE *
C   * ROUTINE IF POSSIBLE.                              *
C   *****************************************************
C
      FUNCTION LOR (IARG1,IARG2)
      LOR=IOR (IARG1,IARG2)
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880525--TERMIC
      SUBROUTINE TERMIC
      STOP
      END
C ----------------------------------------OWNUNC411----UPD850830--XCMD
      SUBROUTINE XCMD(J,LEN)
      RETURN
      END
      SUBROUTINE DB2332(I1,IA2,IA3,I4,I5)
      COMMON /DC2201/ IFLAG(50)
      DIMENSION IA2(*),IA3(*)
      NPRINT = IFLAG(16)
      WRITE(NPRINT,100) I1
100   FORMAT(' DB2332 - CALL',I6)
      I5 = 1
      RETURN
      END
C ----------------------------------------OWNUNC411----UPD880106--DB2310
C    ***********************************************************
C    *                                                         *
C    *     THIS IS THE MAIN ROUTINE OF THE CRYSTIN PLOT        *
C    *     PACKAGE.                                            *
C    *     IT IS CALLED FROM DB2201 (A FEW LINES AFTER         *
C    *     LABEL 3740).                                        *
C    *     TO ACTIVATE THE PACKAGE REMOVE THE "C" IN COL. 1    *
C    *     OF THE LINE CONTAINING "CALL DB2310(......)".       *
C    *                                                         *
C    ***********************************************************
C
      SUBROUTINE DB2310(MNAR,IADR,NBRAS,IRC)
      INTEGER DB2210
      DIMENSION MNAR(*),NBRAS(*)
      COMMON /DC2201/ IFLAG(50)
CHP8  DATA ICY,ICN/'Y','N'/
Cmw      DATAICY,ICN/Z'E8404040',Z'D5404040'/
      DATAICY,ICN/Z'404040E8',Z'404040D5'/
      LNGA = 0
      ITYPAR = 0
      NDSPL = IFLAG(16)
      INI = 0
      IRC=0
      IDBCB = IFLAG(40)
      IACTBS = MNAR(IDBCB+3)
      IF (IACTBS .EQ. 0) CALL DB2315 (88,NBRAS)
      KFIRST = IDBCB + MNAR(IDBCB+1)
      LENDKB = MNAR(IDBCB)
      CALL DB2219 (2310,380)
      CALL DB2231 (MNAR,3840,IADRU)
      IF (IADRU+1) 8802,8801,380
380   CALL UDRAW (MNAR(IADRU),MNAR(IADRU+3200))
      CALL DB2221(MNAR,IADR,1,IREL)
400   CALL DB2221(MNAR,IADR,0,IREL)
      IF(IREL .EQ. 0) GO TO 9000
      IF(INI .EQ. 0) GO TO 410
402   WRITE(NDSPL,404)
404   FORMAT(' Plot next entry of "current subset" (Y/N)?')
      CALL KEYBRD(IFLAG(25),IANTW,1)
      IF(IANTW .EQ. ICN) GO TO 9000
      IF(IANTW .EQ. ICY) GO TO 410
      CALL DB2315(20,NBRAS)
      GO TO 402
410   INI = 1
      IF(IACTBS .EQ. 0) GO TO 9000
      JP = KFIRST
      DO 412 JBAS = 1,IACTBS
      IZUG = MNAR(JP+66)
      IF(IREL .LE. (IZUG + MNAR(JP+130))) GO TO 420
      JP = JP + LENDKB
412   CONTINUE
      GO TO 430
420   CALL DB2250(IREL-IZUG,IZREC,MNAR(JP),NBRAS,IRETCD)
      IF(IRETCD .EQ. 0) GO TO 480
430   WRITE(NDSPL,440) IREL
440   FORMAT(' REL=',I6,' NOT FOUND.')
      GO TO 400
480   LNGB = 3*IZREC + 60
      IF(LNGB .LE. LNGA) GO TO 600
      IF(LNGA .EQ. 0) GO TO 500
      CALL DB2219(2310,480)
      CALL DB2232(MNAR,ITYPAR,NRC)
      IF(NRC .NE. 0) GO TO 8802
500   CALL DB2219(2310,500)
      CALL DB2231(MNAR,LNGB,NRC)
      IF(NRC .LE. 0) GO TO 8801
      ITYPAR = NRC
      LNGA = LNGB
600   CALL DB2251(MNAR(ITYPAR),LNGB,NBRAS,IRETCD)
      IF(IRETCD .LT. 0) GO TO 8803
      IFLAG(36)=0
      IF (IRETCD .LT. 800000) GO TO 680
      IF (IRETCD .GE. 900000) GO TO 680
      IFLAG(36)=1
680   WRITE(NDSPL,700)  IRETCD,IREL
700   FORMAT(1X,/,' **** Collection code COL=',I6,'   (REL=',I6,')',
     1' ****')
      CALL KPLOT(1,MNAR,MNAR(ITYPAR),NBRAS)
      GO TO 400
8801  IRC = 1
      GO TO 9100
8802  IRC = 2
      GO TO 9100
8803  IRC = 3
      GO TO 9100
9000  IF(ITYPAR .EQ. 0) GO TO 9100
      CALL DB2219(2310,9000)
      CALL DB2232(MNAR,ITYPAR,NRC)
9100  INI=-1
      CALL DB2292(MNAR,INI,INI,INI,MNAR,INI,INI,INI,IRK)
      IRK = 0
      IF(IADRU .LE. 0) GO TO 9120
      CALL DB2219 (2310,9100)
      CALL DB2232 (MNAR,IADRU,IRK)
9120  IADRU = 0
      IF (IRK .NE. 0) GO TO 8802
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD880526--KPLOT
                SUBROUTINE KPLOT (IDABA,MNAR,IAR,NBRAS)
      DIMENSION IAIN(72),KONST(40),IOPT(8),MNAR(*),IAR(*),NBRAS(*)
      DIMENSION IPIXLS(2,3),TRBDTA(2,3)
      DIMENSION KD(230),KDNTYP(230)
      DIMENSION IKD0(44)
      DIMENSION IKD1(44)
      DIMENSION IKD2(44)
      DIMENSION IKD3(44)
      DIMENSION IKD4(44)
      DIMENSION IKD5(10)
      DIMENSION IKP6(146)
      DIMENSION IKP7(84)
      INTEGER CDS
      COMMON /KPFLIN/ KARTE(20),KARPOI
      COMMON /KPFCOM/ INTVAR(21),TREIBR(4),REALAR(25)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ IOUNIT(9)
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      COMMON /TFKTRN/ ANTFKT(9,200),NTFKT,NTFDM
      COMMON /DC2201/ IFLAG(50)
      EQUIVALENCE (AIN(1),IAIN(1))
      EQUIVALENCE (CONST(1),KONST(1))
      EQUIVALENCE (IOUNIT(1),NTIN),(IOUNIT(2),NTOUT),(IOUNIT(3),NTPCH)
      EQUIVALENCE (IOUNIT(4),NTSCR),(IOUNIT(5),NTXR1),(IOUNIT(6),NTXR2)
      EQUIVALENCE (IOUNIT(7),NTBILF),(IOUNIT(8),NTDTEI)
      EQUIVALENCE (IOUNIT(9),NTTEMP)
      EQUIVALENCE (KD(1),IKD0(1))
      EQUIVALENCE (KD(45),IKD1(1))
      EQUIVALENCE (KD(89),IKD2(1))
      EQUIVALENCE (KD(133),IKD3(1))
      EQUIVALENCE (KD(177),IKD4(1))
      EQUIVALENCE (KD(221),IKD5(1))
      EQUIVALENCE (KDNTYP(1),IKP6(1))
      EQUIVALENCE (KDNTYP(147),IKP7(1))
      DATA IPIXLS/1023,779,1023,779,719,359/
      DATA TRBDTA/45.47,41.00,45.47,41.00,23.9667,23.9333/
      DATA IBLANK/4H    /,UNDEF1,UNDEF2/4HUNDE,4HFI  /
      DATA KDDIM/230/
      DATA IKD0/4HA   ,4HACAL,4HACI ,4HACIM,4HAE  ,4HAF  ,4HAGLP,4HAKB ,
     14HAKS ,4HAL  ,4HAMC ,4HAO  ,4HAPK ,4HAT  ,4HATAB,4HATB ,4HATG ,
     24HATOM,4HAU  ,4HAUS ,4HAUW ,4HAUZ ,4HAV  ,4HAW  ,4HB   ,4HBA  ,
     34HBF  ,4HBT  ,4HCA  ,4HCE  ,4HCHHP,4HCHPL,4HCRRI,4HDCN ,4HDCS ,
     44HDF  ,4HDG  ,4HDGV ,4HDK  ,4HDKV ,4HDP  ,4HEFTC,4HEFTP,4HEFTS/
      DATA IKD1/4HEN  ,4HEND ,4HENDD,4HEPK ,4HEPL ,4HEPU ,4HES  ,4HEW  ,
     14HEXP ,4HEXPU,4HF   ,4HFDG ,4HFK  ,4HFM  ,4HFMA ,4HFMDD,4HFMDP,
     24HFMDR,4HFMMC,4HFMOP,4HFO  ,4HFRG ,4HFZ  ,4HGLP ,4HGNKO,4HGNZL,
     34HGP  ,4HGT  ,4HGTRM,4HGTY ,4HGTYA,4HH   ,4HHELP,4HHF  ,4HHMS ,
     44HHNH ,4HIMAT,4HIN  ,4HK   ,4HKEE ,4HKF  ,4HKS  ,4HKTG ,4HKUP /
      DATA IKD2/4HKUSP,4HL   ,4HLNP ,4HLPK ,4HLS  ,4HLTF ,4HMINO,4HMVP ,
     14HN   ,4HNAO ,4HNGLP,4HNOI ,4HNOKD,4HNP  ,4HNPEN,4HNPLT,4HNPN ,
     24HNPO ,4HNPR ,4HNRRI,4HNTSO,4HO   ,4HOA  ,4HOAS ,4HOC  ,4HOCG ,
     34HOFMD,4HOH  ,4HOI  ,4HOKD ,4HOMAT,4HOOPT,4HOP  ,4HOPK ,4HOPTR,
     44HOS  ,4HOSY ,4HOT  ,4HOTF ,4HOZ  ,4HOZB ,4HP   ,4HPCDS,4HPG  /
      DATA IKD3/4HPK  ,4HPKS ,4HPL  ,4HPLT ,4HPN  ,4HPO  ,4HPP  ,4HPPFL,
     14HPR  ,4HPREL,4HPSCD,4HPSN ,4HPST ,4HPT  ,4HPVA ,4HPXCM,4HQ   ,
     24HQA  ,4HQAE ,4HQALL,4HQBS ,4HQC  ,4HQFK ,4HQK  ,4HQPK ,4HQRW ,
     34HQSY ,4HQT  ,4HQTF ,4HQUP ,4HQZ  ,4HQZB ,4HR   ,4HRG  ,4HRK  ,
     44HRRI ,4HRS  ,4HRSTR,4HRZ  ,4HS   ,4HSCI ,4HSE  ,4HSH  ,4HSK  /
      DATA IKD4/4HSP  ,4HSPC ,4HSPG ,4HSQLS,4HSQTM,4HSRT ,4HSRTC,4HSRTN,
     14HSRTP,4HSRTT,4HSTP ,4HSTPO,4HSTPU,4HSW  ,4HSY  ,4HT   ,4HTF  ,
     24HTG  ,4HTSO ,4HTW  ,4HTZ  ,4HTZUR,4HUDST,4HUR  ,4HVB  ,4HVBR ,
     34HVBS ,4HVE  ,4HVEH ,4HVEU ,4HVF  ,4HVNRM,4HVP  ,4HVPV ,4HVS  ,
     44HVSR ,4HVSS ,4HW   ,4HWA  ,4HWARP,4HWCOL,4HWK  ,4HWTAB,4HWTB /
      DATA IKD5/4HWV  ,4HWVP ,4HXAT ,4HXK  ,4HXP  ,4HZ   ,4HZF  ,4HZG  ,
     14HZK  ,4HZTAK/
      DATA IKP6/1,7,1,4,9,2,1,2,3,11,4,1,2,2,1,1,3,4,4,7,5,6,9,12,1,5,1,
     16,1,1,1,1,1,5,6,7,6,18,2,21,5,2,1,3,3,1,1,3,14,4,13,7,1,1,1,12,9,2
     2,1,1,3,4,6,8,4,13,5,1,1,1,2,5,1,1,1,1,1,6,1,6,11,2,1,9,10,3,10,6,2
     30,4,2,1,1,2,1,14,6,1,1,1,1,3,1,1,4,1,0,1,1,1,3,7,4,6,7,1,1,1,10,9,
     43,1,8,2,1,5,3,1,5,1,1,1,1,11,4,1,2,1,9,10,1,17,3,4,1,2/
      DATA IKP7/1,1,3,8,10,20,11,4,12,1,2,7,9,5,15,14,13,6,7,2,5,1,8,1,5
     1,11,2,12,1,4,8,19,10,15,16,2,3,5,4,1,1,1,3,1,1,1,1,7,1,10,2,4,1,4,
     22,4,3,14,12,13,5,8,3,2,7,9,8,5,5,11,1,8,2,10,6,6,13,7,12,1,3,11,1,
     36/
      DO 10 I=1,8
   10 IOPT(I)=0
      IOPT(8)=80
   20 IERR=0
      CALL KPPRIM
      NTYDB=0
      IOPT(4)=0
      ISKP(4)=0
      CALL KPLENT (IOPT,MNAR,IAR,NBRAS)
      ISKP(14)=0
      CALL DBINPT (NTYDB,MNAR,IAR,NBRAS)
   50 AIN(1)=0.
      AIN(2)=CONST(8)
      AIN(3)=0.
      AIN(4)=CONST(9)
      CALL KPWPLT (AIN,12)
      AIN(2)=0.
      CALL KPWPLT (AIN,13)
  390 IOPT(1)=NTIN
      IOPT(2)=NTOUT
      IOPT(3)=ISKP(21)
      IOPT(4)=ISKP(4)
      IOPT(5)=ISKP(2)
  400 CALL FLES (IOPT,IOPT,1HO,IOPT)
   60 IF (IERR) 80,80,70
   70 CALL KPERR
   80 IBLKCN=0
      ISKP(20)=0
   85 IBLKCN=IBLKCN+1
      IF (IBLKCN-100) 89,89,86
   86 WRITE (NTOUT,87)
   87 FORMAT (' KPMAIN0087 - Zu viele Leerkarten.')
      GO TO 9999
   89 CONTINUE
      IF (NTYDB) 83,81,81
   81 IF (KARPOI-IOPT(8)) 83,83,91
   83 CALL FLES (KDO,ISKP(31),2HAR,17HPLOT subcommand?$)
      IF (ISKP(31)) 94,94,90
   94 IF (NTYDB) 85,91,91
   91 CALL DBINPT (NTYDB,MNAR,IAR,NBRAS)
      GO TO 89
   90 KV=1
      KH=KDDIM
      CALL CNVTUP (KDO,1,4)
      GO TO 120
  100 KV=KDGO+1
  110 IF (KV-KH) 120,120,140
  120 KDGO=(KV+KH)/2
      IF (LCOMPS(KDO,1,4,KD(KDGO),1)) 130,170,100
  130 KH=KDGO-1
      GO TO 110
  140 CALL FLES (AIN,AIN,1HK,AIN)
      WRITE (NTOUT,150) KDO
  150 FORMAT (' KPMN150 - Command ''',A4,''' not found.')
  160 CALL FLES (AIN,ISKP(31),1HE,2H?$)
      GO TO 60
  170 NTYP=KDNTYP(KDGO)
      GO TO (530,750,420,420,610,950,1020,210,210,530,750,650,1060,610,1
     1090,210,610,610,210,210,210,210,750,530,1050,430,950,430,360,350,1
     2410,1420,790,420,420,950,540,540,200,540,540,1120,1120,1120,420,44
     30,570,1060,610,980,610,530,1340,1330,470,750,530,1390,1390,1400,13
     490,1390,1390,1390,620,750,1390,990,1370,1380,980,610,1490,520,1080
     5,410,1210,950,1030,820,200,530,200,200,610,180,200,190,540,530,135
     60,460,690,1450,1260,540,610,660,1000,920,600,1350,1440,720,1350,68
     70,1630,780,580,480,320,320,320,320,1390,1100,930,590,320,320,540,1
     8060,320,320,740,320,1450,320,950,540,1310,960,430,430,540,710,1310
     9,670,540,430,1630,540,1310,1310,450,540,750,1480,1070,1070,1070,10
     A70,1070,1070,1070,1070,1070,1070,1070,1070,1070,1070,1070,1070,610
     B,1030,190,800,610,20,180,610,420,610,1620,190,540,540,540,610,610,
     C820,820,820,820,820,980,1560,980,970,730,610,1450,540,570,530,180,
     D180,1360,950,430,430,430,430,430,430,620,750,750,750,430,430,430,5
     E30,750,750,1600,190,1090,750,750,530,540,190,540,180,950,540,1570,
     F180),KDGO
  180 CALL KPZ
      GO TO 60
  190 CALL FLES (AIN,ISKP(31),1HE,2H?$)
  200 CALL KPK
      GO TO 60
  210 CALL KPAVBR
      GO TO 60
  320 CALL KPO
      GO TO 60
  350 CALL FLES (NCD,ISKP(31),2HIE,6HAnz.?$)
      K8=MIN0(K8,NCD)
      K9=MIN0(K9,NCD)
      GO TO 60
  360 CALL FLES (NCDA,ISKP(31),2HIE,6HAnz.?$)
      GO TO 60
  380 CALL FLES (AIN,ISKP(31),1HE,2H?$)
      GO TO 390
  410 CALL FLES (HOE,ISKP(31),2HFE,7HHoehe?$)
      GO TO 60
  420 CALL KPASCI
      GO TO 60
  430 CALL KPLPK
      GO TO 60
  440 CALL KPWPLT (AIN,-1)
      GO TO 9999
  450 DO 455 I=1,18
  455 AIN(I+1)=TITEL(I)
      AIN(1)=72.
      CALL FLES (CONST(32),ISKP(31),3H2FE,13Hxsize,ysize?$)
      AIN(20)=CONST(32)
      AIN(21)=CONST(33)
      CALL KPWPLT (AIN,1)
      GO TO 60
  460 IPKP=1
      IVBP=1
      GO TO 160
  470 CALL FLES (O8,ISKP(31),2HFE,8HFaktor?$)
      O9=O8
      GO TO 60
  480 CALL KPORTN
      GO TO 160
  520 CALL KPGTY
      GO TO 60
  530 CALL KPGE02
      GO TO 60
  540 CALL KPGE01
      GO TO 60
  570 ISKP(4)=1
      GO TO 380
  580 ISKP(4)=0
      GO TO 380
  590 ISKP(2)=1
      GO TO 380
  600 ISKP(2)=0
      GO TO 380
  610 CALL KPFNIN
      GO TO 60
  620 AIN(1)=0.
      AIN(2)=0.
      CALL FLES (AIN,ISKP(31),3H2FE,5Hx,y?$)
      CALL KPWPLT (AIN,NTYP)
      GO TO 60
  650 ISKP(5)=1
      GO TO 160
  660 ISKP(5)=0
      GO TO 160
  670 ISKP(6)=1
      GO TO 160
  680 ISKP(6)=0
      GO TO 160
  690 CALL KPWPLT (AIN,6)
      GO TO 160
  710 ISKP(7)=1
      GO TO 160
  720 ISKP(7)=0
      GO TO 160
  730 CALL KPSYDC
      GO TO 60
  740 CALL KPSYOU
      GO TO 160
  750 CALL KPGE03
      GO TO 60
  780 ISKP(11)=0
      GO TO 160
  790 ISKP(11)=1
      GO TO 160
  800 ISKP(11)=2
      GO TO 160
  820 CALL KPSRT
      GO TO 60
  920 ISKP(12)=0
      GO TO 160
  930 ISKP(12)=1
      GO TO 160
  950 CALL KPFKTR
      GO TO 60
  960 AIN(1)=0.
      AIN(2)=0.
      CALL FLES (AIN,ISKP(31),3H2FE,9Hpgx,pgy?$)
      CALL KPWPLT (AIN,13)
      GO TO 60
  970 CALL FLES (CONST(13),ISKP(31),2HFE,8HWinkel?$)
      GO TO 60
  980 CALL KPMACR
      GO TO 60
  990 ISKP(15)=0
      GO TO 1010
 1000 ISKP(15)=1
 1010 CALL FLES (CONST(21),ISKP(31),2HFE,5HTol?$)
      GO TO 60
 1020 ISKP(15)=-1
      GO TO 160
 1030 CALL KPHMSD (MNAR,NBRAS)
      GO TO 60
 1050 CALL KPLABL
      GO TO 60
 1060 CALL KPPKED
      GO TO 60
 1070 CALL KPBILF
      GO TO 60
 1080 CALL KPGTYA
      GO TO 60
 1090 CALL KPAWTB
      GO TO 60
 1100 TEMP=O9*HOE
      WRITE (NTOUT,1110) TEMP
 1110 FORMAT (' Betrachterabstand =',F10.2)
      GO TO 160
 1120 CALL KPEFIT
      GO TO 60
 1210 WRITE (NTOUT,1220)
 1220 FORMAT (' Commands provided:')
      WRITE (NTOUT,1230) (KD(I),I=1,KDDIM)
 1230 FORMAT (12('  ',A4))
      GO TO 160
 1260 CALL KPMINO
      GO TO 60
 1310 CALL KPPNCD
      GO TO 60
 1330 ISKP(25)=1
      GO TO 1350
 1340 ISKP(25)=0
 1350 CALL KPEXPU
      IF (NTYP-1) 60,160,60
 1360 KONST(25)=0
      CALL FLES (CONST(23),ISKP(31),4H2FIE,11Hu0,u1,typ?$)
      ISKP(27)=KONST(25)
      GO TO 60
 1370 CALL KPGNKO
      GO TO 60
 1380 CALL KPGNZL
      GO TO 60
 1390 CALL KPGOML
      GO TO 60
 1400 CALL FLES (CONST(31),ISKP(31),2HFE,6Hdmax?$)
      GO TO 60
 1410 ISKP(26)=0
      GO TO 160
 1420 ISKP(26)=1
      GO TO 160
 1440 CALL FLES (AIN,ISKP(31),2HFE,8HPen-Nr?$)
      CALL KPWPLT (AIN,10)
      GO TO 60
 1450 CALL KPTFHN
      GO TO 60
 1480 CALL FLES (AIN,ISKP(31),3H4FE,25Hpx(x),cm(x),px(y),cm(y)?$)
      CALL KPWPLT (AIN,18)
      GO TO 60
 1490 CALL FLES (I,ISKP(31),2HIE,
     1 58H0: No terminal; 1: Tektronix;2: Tektronix (Proco); 3: HP?$)
      INTVAR(19)=I
      IF (I) 60,60,1500
 1500 IF (I-3) 1520,1520,1510
 1510 ISKP(10)=11510
      IERR=16
      GO TO 60
 1520 DO 1530 J=1,2
      INTVAR(19+J)=IPIXLS(J,I)
      TREIBR(2+J)=TRBDTA(J,I)
 1530 CONTINUE
      GO TO 60
 1560 CALL FLES (ISKP(13),ISKP(31),2HIE,5HOpt?$)
      INTVAR(14)=ISKP(13)
      GO TO 60
 1570 CALL KPZK
      GO TO 60
 1600 WRITE (NTOUT,1610) IFLAG(20)
 1610 FORMAT (' COL =',I7)
      GO TO 160
 1620 CALL FLES (CONST(15),ISKP(31),2HFE,11HSchrifth.?$)
      REALAR(10)=CONST(15)
      GO TO 60
 1630 ISKP(3)=NTYP
      GO TO 160
 9999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880611--CNVTLO
C NVTLO        ---------------------------------------
                SUBROUTINE CNVTLO (STRING,ISTART,LEN)
      INTEGER STRING(*)
      I=ISTART
      J=1
   10 CALL CHRINT (STRING,I,1,N)
      IF (N .LT.  65) GO TO 20
      IF (N .LT.  91) CALL INTCHR (N+32,1,STRING,I)
   20 I=I+1
      J=J+1
      IF (J .LE. LEN) GO TO 10
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD880611--CNVTUP
C NVTUP        ---------------------------------------
                SUBROUTINE CNVTUP (STRING,ISTART,LEN)
      INTEGER STRING(*)
      I=ISTART
      J=1
   10 CALL CHRINT (STRING,I,1,N)
      IF (N .LT.  97) GO TO 20
      IF (N .LT. 123) CALL INTCHR (N-32,1,STRING,I)
   20 I=I+1
      J=J+1
      IF (J .LE. LEN) GO TO 10
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD870504--CVNTST
C VNTST        ----------------------------------------
                SUBROUTINE CVNTST (IZAHL, STRING,IPOI)
      DIMENSION STRING(*),ISUB(9),IZFFRN(3)
      DATA ISUB/1000000000,100000000,10000000,1000000,100000,10000,
     1 1000,100,10/,IZFFRN/4H0123,4H4567,4H89- /
      J=1
      I=IZAHL
      IF (I) 10,20,20
   10 I=-I
      CALL COPYCH (IZFFRN,11,1, STRING,IPOI)
      IPOI=IPOI+1
   20 N=I-ISUB(J)
      IF (N) 30,40,40
   30 J=J+1
      IF (J-10) 20,70,70
   40 K=1
      GO TO 60
   50 K=K+1
      I=N
   60 N=I-ISUB(J)
      IF (N) 80,50,50
   70 K=I+1
   80 CALL COPYCH (IZFFRN,K,1, STRING,IPOI)
      IPOI=IPOI+1
      J=J+1
      IF (J-10) 40,70,999
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--DBINPT
               SUBROUTINE DBINPT (NTY,MNAR,IAR,NBRAS)
      DIMENSION IAR(*),NBRAS(*),MNAR(*)
      COMMON /DC2201/ IFLAG(50)
      COMMON /KPFLIN/ IARRAY(20),KARPOI
      COMMON /KPFCOM/ INTAR(50)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)                                 !AWH12/12/96
CHP8  DATA ITMP/0/,IBLANK/'    '/,IDBEND/'ENDD'/
Cmw      DATAITMP/0/,IBLANK/Z'40404040'/,IDBEND/Z'C5D5C4C4'/
      DATAITMP/0/,IBLANK/Z'40404040'/,IDBEND/Z'C4C4D5C5'/
      DATA IBUUNS/109/,IBUBLK/64/
      IF (NTY) 999,20,10
   10 IF (IPOI) 70,70,180
   20 NTY=1
      IPOS=0
      IPOI=0
   30 CALL DB2219 (5555,40)
      CALL DB2235 (MNAR,LENW,IADRW)
      IF (IADRW) 40,40,60
   40 WRITE (NTOUT,50)
   50 FORMAT (' System error.  Missing work area.')
      NTY=-1
      KARPOI=81
      GO TO 999
   60 LENB=LENW*4
      IADRB=(IADRW-1)*4+1
   70 IPOS=IPOS+1
      CALL DB2252 (19,IPOS,IAR,NBRAS,NRC)
      IF (NRC) 80,80,170
   80 IF (IPOS-1) 140,140,90
   90 IF (INTAR(19)) 100,120,120
  100 WRITE (NTOUT,110)
  110 FORMAT (' Type  GTRM  to select Graphics Terminal type.')
  120 WRITE (NTOUT,130)
  130 FORMAT (' Type  EPU  to plot the standard picture.')
  140 CALL DB2219 (5555,120)
      CALL DB2232 (MNAR,IADRW,NRC)
      IF (NRC) 40,150,40
  150 IARRAY(1)=IDBEND
      DO 160 I=2,20
  160 IARRAY(I)=IBLANK
      KARPOI=0
      NTY=-1
      GO TO 270
  170 CALL DB2260 (1,MNAR(IADRW),LENB,LEN,NBRAS)
      IPOI=IADRB
      IADRL=IADRB+LEN-1
  180 DO 190 I=1,20
  190 IARRAY(I)=IBLANK
      I=0
      KARPOI=0
  200 I=I+1
      CALL CHRINT (MNAR,IPOI,1, ITMP)
      IPOI=IPOI+1
      IF (ITMP-IBUUNS) 210,220,230
  210 IF (ITMP-IBUBLK) 230,250,230
  220 ITMP=IBUBLK
  230 CALL INTCHR (ITMP,1,IARRAY,I)
      IF (IPOI-IADRL) 240,240,260
  240 IF (I-80) 200,270,270
  250 IF (IPOI-IADRL) 270,260,260
  260 IPOI=0
  270 CONTINUE
      CALL EBCA (IARRAY,1,80)
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--FCNV
       SUBROUTINE FCNV (AIN,NZBUF,LFRM,KARTE,KARPOI,KAREND,IRC)
      DIMENSION AIN(*),NZBUF(*),LFRM(*),KARTE(*)
      DIMENSION ZPOT1(10),ZPOT2(7),IBUZFF(16)
      EQUIVALENCE (IWORT,WORT),(IFXAC,FXAC)
      DATA IFXMAX/16777215/,ILZCH/0/,BLK/4H    /,IERZVD/0/
      DATA ZPOT1/1.,10.,100.,1.E3,1.E4,1.E5,1.E6,1.E7,1.E8,1.E9/
      DATA ZPOT2/1.E10,1.E20,1.E30,1.E30,1.E30,1.E30,1.E30/
      DATA IEXLIM/38/
      DATA IBUBLK,IBUPKT,IBUKLA,IBUPLS,IBUSTN/32,46,40,43,42/
      DATA IBUKLZ,IBUMNS,IBUSLA,IBUKOM,IBUAPO/41,45,47,44,39/
      DATA IBUA,IBUB,IBUE,IBUF,IBUG,IBUI/65,66,69,70,71,73/
      DATA IBUR,IBUS,IBUKAE/82,83,255/
      DATA IBUSMI/59/,IBUJ/74/,IBUZ/90/
      DATA IBUZFF/48,49,50,51,52,53,54,55,
     1            56,57,65,66,67,68,69,70/
      IVBFLG=0
      IENDFL=0
      IF (IRC .GT. -1) GO TO 10
      IRC=0
      GO TO 400
   10 IF (IRC .NE. 3) GO TO 20
      IRC=0
      GO TO 50
   20 IRC=0
      INFOFL=0
      INPOI=0
      INPOIS=0
      NZPOI=0
      IFRPOI=0
      GO TO 50
   30 INCOU=-1
   40 INPOI=INPOIS+IFRAC
      INPOIS=INPOI
      NZBUF(NZPOI)=INCOU
      IF (IRC .NE. 0) GO TO 1120
   50 IFRAC=0
      INCOU=0
   60 IFRPOI=IFRPOI+1
      ILZCH=0
      CALL CHRINT (LFRM,IFRPOI,1, ILZCH)
      IF (ILZCH .LT. IBUZFF(1)) GO TO 70
      IF (ILZCH .GT. IBUZFF(10)) GO TO 70
      IFRAC=IFRAC*10+ILZCH-IBUZFF(1)
      GO TO 60
   70 IF (IFRAC .LE. 0) IFRAC=1
      NZPOI=NZPOI+1
      IF (IENDFL .EQ. 0) GO TO 180
      IF (ILZCH-IBUR) 80,1120,90
   80 IF (ILZCH-IBUE) 40,1120,40
   90 IF (ILZCH-IBUS) 100,1120,100
  100 IRC=1
      GO TO 1120
  110 IF (ILZCH-IBUA) 100,210,100
  120 IF (ILZCH-IBUB) 110,220,130
  130 IF (ILZCH-IBUE) 100,300,100
  140 IF (ILZCH-IBUF) 120,230,160
  150 IF (ILZCH-IBUG) 100,240,100
  160 IF (ILZCH-IBUI) 150,250,170
  170 IF (ILZCH-IBUJ) 100,260,100
  180 IF (ILZCH-IBUR) 140,1120,190
  190 IF (ILZCH-IBUS) 100,290,200
  200 IF (ILZCH-IBUZ) 100,280,100
  210 IFRGO=-1
      IBFLEN=4
      GO TO 490
  220 IFRGO=-1
      IBFLEN=1
      GO TO 490
  230 IFRGO=0
      GO TO 490
  240 IFRGO=4
      GO TO 490
  250 IFRGO=1
      GO TO 270
  260 IFRGO=2
  270 IFXBAS=10
      GO TO 490
  280 IFRGO=3
      IFXBAS=16
      GO TO 490
  290 IERZVD=1
  300 IZRET=1
      GO TO 400
  310 IF (ILZCH-IBUBLK) 390,400,320
  320 IF (ILZCH .NE. IBUKLA) GO TO 380
  330 KLACOU=1
      IZRETS=IZRET
      IZRET=2
      GO TO 400
  340 IF (ILZCH-IBUKLZ) 360,350,370
  350 KLACOU=KLACOU-1
      IF (KLACOU .GT. 0) GO TO 400
      IZRET=IZRETS
      GO TO 400
  360 IF (ILZCH .NE. IBUKLA) GO TO 400
      KLACOU=KLACOU+1
      GO TO 400
  370 IF (ILZCH .LT. IBUKAE) GO TO 400
      IRC=-2
      GO TO 1120
  380 IF (ILZCH .EQ. IBUSLA) GO TO 1120
      IF (ILZCH .EQ. IBUSMI) GO TO 1120
      IF (ILZCH .GE. IBUKAE) GO TO 1120
  390 IF (IERZVD .NE. 0) GO TO 400
      IRC=2
      GO TO 40
  400 IF (IVBFLG .EQ. 0) GO TO 430
      IVBFLG=0
      IF (KARPOI) 410,440,420
  410 IRC=7
      GO TO 1120
  420 IF (KARPOI-KAREND) 450,450,480
  430 IF (KARPOI-KAREND) 440,470,410
  440 KARPOI=KARPOI+1
  450 ILZCH=0
      CALL CHRINT (KARTE,KARPOI,1, ILZCH)
  460 GO TO (310,340,500,680,740,860,900,1030,940),IZRET
  470 KARPOI=KARPOI+1
  480 ILZCH=IBUKAE
      GO TO 460
  490 KOCOU=0
      IZRET=3
      GO TO 400
  500 IF (ILZCH-IBUBLK) 600,400,510
  510 IF (ILZCH .NE. IBUKOM) GO TO 520
      IF (KOCOU .GT. 0) GO TO 530
      KOCOU=1
      GO TO 400
  520 IF (ILZCH-IBUSTN) 560,540,560
  530 IVBFLG=1
  540 INFOFL=1
      IF (IFRGO .GE. 0) GO TO 550
      INCOU=IFRAC
      GO TO 40
  550 INCOU=INCOU+1
      INPOI=INPOI+1
      IF (INCOU-IFRAC) 490,40,40
  560 IF (ILZCH .EQ. IBUKLA) GO TO 330
      IF (ILZCH .EQ. IBUSLA) GO TO 570
      IF (ILZCH .NE. IBUSMI) GO TO 580
  570 INFOFL=1
      GO TO 590
  580 IF (ILZCH .LT. IBUKAE) GO TO 600
  590 IENDFL=1
      GO TO 40
  600 IF (IFRGO) 620,930,610
  610 IF (IFRGO-4) 800,930,800
  620 IF (ILZCH .NE. IBUAPO) GO TO 700
      IZRET=4
      WORT=BLK
      IPOI=0
      IAPFLG=0
      INFOFL=1
      GO TO 400
  630 IAPFLG=0
  640 IF (ILZCH .LT. IBUKAE) GO TO 650
      IRC=-1
      IF (INCOU .LT. IFRAC) GO TO 1120
      IRC=-3
      GO TO 1120
  650 IF (IPOI .LT. IBFLEN) GO TO 670
      IF (INCOU .GE. IFRAC) GO TO 660
      INCOU=INCOU+1
      INPOI=INPOI+1
      AIN(INPOI)=WORT
  660 WORT=BLK
      IPOI=0
  670 IPOI=IPOI+1
      CALL COPYCH (ILZCH,4,1, WORT,IPOI)
      GO TO 400
  680 IF (ILZCH .NE. IBUAPO) GO TO 690
      IF (IAPFLG .NE. 0) GO TO 630
      IAPFLG=1
      GO TO 400
  690 IF (IAPFLG) 750,640,750
  700 IZRET=5
      INFOFL=1
      GO TO 720
  710 INCOU=INCOU+1
      INPOI=INPOI+1
      AIN(INPOI)=WORT
  720 WORT=BLK
      IPOI=0
  730 IPOI=IPOI+1
      CALL COPYCH (ILZCH,4,1, WORT,IPOI)
      GO TO 400
  740 IF (ILZCH .EQ. IBUBLK) GO TO 750
      IF (ILZCH .EQ. IBUKOM) GO TO 750
      IF (ILZCH .EQ. IBUSLA) GO TO 750
      IF (ILZCH .EQ. IBUSMI) GO TO 750
      IF (ILZCH .EQ. IBUSTN) GO TO 750
      IF (ILZCH .LT. IBUKAE) GO TO 760
  750 IVBFLG=1
      INKOU=INCOU
      GO TO 780
  760 IF (IPOI .LT. IBFLEN) GO TO 730
      IF (INCOU-IFRAC) 710,720,720
  770 INPOI=INPOI+1
      AIN(INPOI)=WORT
      INKOU=INKOU+1
      WORT=BLK
      IPOI=0
  780 IF (INKOU .LT. IFRAC) GO TO 770
      IF (IPOI .LE. 0) GO TO 790
      IRC=3
      GO TO 40
  790 INCOU=INCOU+1
      GO TO 40
  800 IMNSFL=1
      IF (ILZCH .EQ. IBUMNS) GO TO 840
      IF (ILZCH .EQ. IBUPLS) GO TO 850
      DO 810 INUM=1,IFXBAS
      IF (ILZCH .EQ. IBUZFF(INUM)) GO TO 880
  810 CONTINUE
  820 IF (IFRGO .NE. 2) GO TO 830
      IVBFLG=1
      GO TO 40
  830 IRC=4
      GO TO 30
  840 IMNSFL=-1
  850 IZRET=6
      GO TO 400
  860 DO 870 INUM=1,IFXBAS
      IF (ILZCH .EQ. IBUZFF(INUM)) GO TO 880
  870 CONTINUE
      GO TO 820
  880 IFXAC=INUM-1
      IZRET=7
      GO TO 400
  890 IFXAC=IFXAC*IFXBAS+INUM-1
      GO TO 400
  900 DO 910 INUM=1,IFXBAS
      IF (ILZCH .EQ. IBUZFF(INUM)) GO TO 890
  910 CONTINUE
      IFXAC=IFXAC*IMNSFL
  920 INCOU=INCOU+1
      INPOI=INPOI+1
      AIN(INPOI)=FXAC
      IVBFLG=1
      INFOFL=1
      IF (INCOU-IFRAC) 490,40,40
  930 IPKTFL=0
      IBUCHE=0
  940 IFXAC=0
      IMNSFL=1
      IEXAC=0
      IMXFL=0
      IZRET=8
      IF (ILZCH .NE. IBUMNS) GO TO 950
      IMNSFL=-1
      GO TO 400
  950 IF (ILZCH .EQ. IBUPLS) GO TO 400
      IF (ILZCH .NE. IBUPKT) GO TO 970
  960 IF (IPKTFL .GT. 0) GO TO 980
      IPKTFL=1
      GO TO 400
  970 IF (ILZCH .LT. IBUZFF(1)) GO TO 980
      IF (ILZCH .LE. IBUZFF(10)) GO TO 1010
  980 IF (IFRGO .NE. 4) GO TO 990
      IVBFLG=1
      GO TO 40
  990 IRC=5
      GO TO 30
 1000 IF (IMXFL .GT. 0) GO TO 1020
      IF (IFXAC .LT. IFXMAX) GO TO 1010
      IMXFL=1
      GO TO 1020
 1010 IFXAC=IFXAC*10-IBUZFF(1)+ILZCH
 1020 IEXAC=IEXAC+IMXFL-IPKTFL
      GO TO 400
 1030 IF (ILZCH .LT. IBUZFF(1)) GO TO 1040
      IF (ILZCH .LE. IBUZFF(10)) GO TO 1000
 1040 IF (ILZCH .EQ. IBUPKT) GO TO 960
      IF (ILZCH .NE. IBUE) GO TO 1050
      IF (IBUCHE .NE. 0) GO TO 1050
      IBUCHE=1
      IPKTFL=1
      IFXSV=IFXAC*IMNSFL
      IEXSV=IEXAC
      IZRET=9
      GO TO 400
 1050 IF (IBUCHE .NE. 0) GO TO 1060
      IFXAC=IFXAC*IMNSFL
      GO TO 1070
 1060 IEXAC=IEXSV+IFXAC*IMNSFL
      IFXAC=IFXSV
 1070 FXAC=FLOAT(IFXAC)
      I=IABS(IEXAC)
      IF (I .LE. IEXLIM) GO TO 1080
      IRC=6
      GO TO 30
 1080 IF (I .LE. 0) GO TO 920
      J=I/10
      I=I-10*J
      EX=ZPOT1(I+1)
      IF (J .LE. 0) GO TO 1090
      EX=EX*ZPOT2(J)
 1090 IF (IEXAC) 1110,920,1100
 1100 FXAC=FXAC*EX
      GO TO 920
 1110 FXAC=FXAC/EX
      GO TO 920
 1120 IERZVD=0
      KARPOI=KARPOI-IVBFLG
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--FLES
                SUBROUTINE FLES (AIN,NZBUF,LFRM,LTXT)
      DIMENSION AIN(*),NZBUF(*),LFRM(*),LTXT(*)
      COMMON /KPFLIN/ KARTE(20),KARPOI
      CHARACTER NNCHAR
      DATA NTIN/5/,NTOUT/6/,NTSCR/0/,ITSOFL/0/,IPROTF/0/
      DATA IBLKIG/0/,KARBEG/1/,KAREND/80/,IH/0/,KARCOU/0/,IBLK/4H    /
      DATA IRC/0/,DLR/1H$/
      DATA L1/1/,L2/2/,L3/3/,L4/4/,L5/5/,L6/6/,L7/7/,L8/8/
      DATA IBUBLK/32/,IBUDLR/36/,IBUE/69/,IBUS/83/
      DATA IBUK/75/,IBUO/79/
      CALL CHRINT (LFRM,1,1, IH)
      IF (IH-IBUK) 40,10,20
   10 ASSIGN 994 TO NRET
      GO TO 320
   20 IF (IH-IBUO) 40,30,40
   30 IF (NZBUF(L1) .GT. 0) NTIN=NZBUF(L1)
      IF (NZBUF(L2) .GT. 0) NTOUT=NZBUF(L2)
      IF (NZBUF(L3) .GT. 0) NTSCR=NZBUF(L3)
      ITSOFL=NZBUF(L4)
      IPROTF=NZBUF(L5)
      IBLKIG=NZBUF(L6)
      IF (NZBUF(L7) .GT. 0) KARBEG=NZBUF(L7)
      IF (NZBUF(L8) .GT. 0) KAREND=NZBUF(L8)
      GO TO 999
   40 CONTINUE
      IF (KARPOI-KAREND) 230,230,70
   70 IF (ITSOFL) 250,130,250
   80 DO 90 I=1,20
   90 KARTE(I)=IBLK
      DO 100 I=1,72
      CALL CHRINT (LTXT,I,1, IH)
      IF (IH-IBUDLR) 100,110,100
  100 CONTINUE
      I=73
  110 I=I-1
      CALL COPYCH (LTXT,1,I, KARTE,1)
      I=(I+3)/4
      WRITE (NTOUT,120) (KARTE(JJJ),JJJ=1,I)
  120 FORMAT (' ',18A4)
  130 IF (IRC+3) 170,140,170
  140 ASSIGN 150 TO NRET
      GO TO 320
  150 WRITE (NTOUT,160)
  160 FORMAT (' Missing closing quote.')
  170 CALL KEYBRD (NTIN,KARTE,20)
      CALL EBCA (KARTE,1,80)
  180 FORMAT (20A4)
      KARCOU=KARCOU+1
      IF (IPROTF) 190,200,190
  190 WRITE (NTOUT,390) KARCOU,KARTE
  200 IF (NTSCR) 220,220,210
  210 WRITE (NTSCR,180) KARTE
  220 KARPOI=KARBEG-1
  230 IF (ITSOFL) 250,300,250
  240 CALL CHRINT (KARTE,I,1, IH)
      IF (IH-IBUBLK) 300,260,300
  250 I=KARPOI
  260 I=I+1
      IF (I-KAREND) 240,240,270
  270 IF (IRC) 300,280,280
  280 CALL CHRINT (LFRM,1,1, IH)
      IF (IH-IBUE) 80,999,290
  290 IF (IH-IBUS) 80,999,80
  300 CALL FCNV (AIN,NZBUF,LFRM,KARTE,KARPOI,KAREND,IRC)
      IF (IRC) 130,999,310
  310 ASSIGN 410 TO NRET
  320 J=KARPOI
      JJ=KAREND
      GO TO 350
  330 IF (JJ-1) 360,360,340
  340 JJ=JJ-1
  350 CALL CHRINT (KARTE,JJ,1, IH)
      IF (IH-IBUBLK) 360,330,360
  360 IF (JJ-J) 370,380,380
  370 J=JJ
  380 JJ=(JJ+3)/4
      WRITE (NTOUT,390) KARCOU,(KARTE(JJJ),JJJ=1,JJ)
  390 FORMAT (' Line',I5,'->',20A4)
      WRITE (NTOUT,400) (IBLK,I=1,J),DLR
  400 FORMAT (' **** Error',82A1)
      GO TO NRET,(150,410,994)
  410 GO TO (420,440,460,480,500,520,540),IRC
  420 WRITE (NTOUT,430) (LFRM(J),J=1,2)
  430 FORMAT (' Format-Error: ',2A4)
      GO TO 999
  440 WRITE (NTOUT,450)
  450 FORMAT (' Unexpected Information.')
      GO TO 560
  460 WRITE (NTOUT,470)
  470 FORMAT (' String too long.')
      GO TO 300
  480 WRITE (NTOUT,490)
  490 FORMAT (' Illegal character in integer number.')
      GO TO 560
  500 WRITE (NTOUT,510)
  510 FORMAT (' Illegal character in real number.')
      GO TO 560
  520 WRITE (NTOUT,530)
  530 FORMAT (' Number out of range.')
      GO TO 560
  540 WRITE (NTOUT,550) KARPOI
  550 FORMAT (' Ill. Adr. on buffer:',I6)
      GO TO 999
  560 IF (ITSOFL) 996,570,996
  570 NNCHAR='S'                                !replacing explicit 'S' below AWH

      CALL FCNV (AIN,NZBUF,NNCHAR,KARTE,KARPOI,KAREND,IRC)
      GO TO 999
  994 IF (ITSOFL) 996,999,996
  996 KARPOI=KAREND
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD871218--KPADD
                          SUBROUTINE KPADD
      DIMENSION XUR(3),XU(3),XO(3),XAKT(3),XSTRT(3),XKRT(3),XDIM(3)
      DIMENSION IT1(3),IT2(3),IAT(6,200)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)                                 !AWH12/12/96
      EQUIVALENCE (IT1(1),I1),(IT1(2),J1),(IT1(3),K1)
      EQUIVALENCE (IT2(1),I2),(IT2(2),J2),(IT2(3),K2)
      EQUIVALENCE (XUR(1),X(1,1)),(XU(1),X(1,2)),(XO(1),X(1,3))
      EQUIVALENCE (XAKT(1),X(1,4)),(XSTRT(1),X(1,5))
      EQUIVALENCE (XKRT(1),X(1,6)),(XDIM(1),X(1,7)),(AIN(72),IDQC)
      EQUIVALENCE (AT(1,1),IAT(1,1))
      DATA T1/0./
      IF (NSYM) 10,10,20
   10 ISKP(10)=20010
      IERR=5
      GO TO 999
   20 NCDE=NCD
      K9=0
      NC=5
      NTRY=40
      IC=K8
      GO TO 50
   30 IC=IC+1
      CALL KPDEK
      DO 40 I=1,3
   40 ATOMS(I,IC)=XSTRT(I)
   50 IF (IC-NCD) 30,60,60
   60 K8=NCD
      DO 70 I=1,3
      XU(I)=XUR(I)-XDIM(I)-.00001
      XO(I)=XUR(I)+XDIM(I)+.00001
   70 CONTINUE
      DO 700 IANR=IZ1,IZ2
      IF (IANR) 90,90,80
   80 IF (IANR-NAT) 100,100,90
   90 ISKP(10)=20090
      IERR=4
      GO TO 999
  100 IAT1=IANR*100000
      IAT2=IAT1+99999
      I=NCDA
      IF (ISKP(15)) 110,120,160
  110 IS=NCD+1
      GO TO 170
  120 IF (I-NCD) 130,130,160
  130 IF (ICD(I)-IAT1) 150,150,140
  140 IF (ICD(I)-IAT2) 160,150,150
  150 I=I+1
      GO TO 120
  160 IS=I
  170 DO 690 ISYNR=1,NSYM
      NTRY=8
      DO 180 I=1,3
  180 IT(I)=5
      NC=4
      CALL KPDEK
      DO 300 I=1,3
      J=5
      TEMP=XAKT(I)
      GO TO 200
  190 TEMP=TEMP-1.
      J=J-1
  200 IF (TEMP-1.-XU(I)) 220,190,190
  210 TEMP=TEMP+1.
      J=J+1
  220 IF (TEMP-XU(I)) 210,230,230
  230 K=J
      XSTRT(I)=TEMP
      GO TO 250
  240 TEMP=TEMP+1.
      K=K+1
  250 IF (TEMP+1.-XO(I)) 240,240,270
  260 TEMP=TEMP-1.
      K=K-1
  270 IF (TEMP-XO(I)) 280,280,260
  280 IF (K-J) 690,290,290
  290 IT1(I)=J
      IT2(I)=K
  300 CONTINUE
      XAKT(1)=XSTRT(1)
      DO 680 I=I1,I2
      XAKT(2)=XSTRT(2)
      DO 670 J=J1,J2
      XAKT(3)=XSTRT(3)
      DO 660 K=K1,K2
      IF (NTYP-2) 390,370,310
  310 NTRY=2
      NC=4
      CALL KPDEK
      IF (CONST(19)) 340,340,320
  320 T1=0.
      DO 330 L=1,3
      TEMP=X1(L)-CONST(15+L)
  330 T1=T1+TEMP*TEMP
      IF (T1-CONST(19)) 340,340,650
  340 T1=0.
      DO 350 L=1,3
      TEMP=X1(L)-X2(L)
  350 T1=TEMP*TEMP+T1
      IF (T1-DQ) 360,360,650
  360 IF (T1-CONST(20)) 650,390,390
  370 NTRY=4
      NC=4
      CALL KPDEK
      DO 380 L=1,3
      IF (ABS(X2(L))-XKRT(L)) 380,380,650
  380 CONTINUE
  390 IF (IS -NCD) 400,400,460
  400 DO 450 M=IS,NCD
      IF (ISKP(15)) 460,410,430
  410 IF (ICD(M)-IAT1) 450,450,420
  420 IF (ICD(M)-IAT2) 430,450,450
  430 DO 440 L=1,3
      IF (ABS(ATOMS(L,M)-XAKT(L))-CONST(21)) 440,440,450
  440 CONTINUE
      GO TO 650
  450 CONTINUE
  460 IF (NTYP-7) 530,470,530
  470 NCHBRN=ISKP(28)
      L=ISKP(30)
      GO TO 510
  480 L=L+1
      M=ICD(L)/100000
      M=IAT(5,M)
      CALL CNVTUP (M,1,4)
      IF (M .NE. ISKP(29)) GO TO 520
      DO 490 LL=1,3
  490 X1(LL)=XAKT(LL)-ATOMS(LL,L)
      T1=0.
      DO 500 LL=1,3
      T2=DG(LL,1)*X1(1)+DG(LL,2)*X1(2)+DG(LL,3)*X1(3)
      T1=T1+T2*T2
      IF (T1-DQ) 500,500,520
  500 CONTINUE
  510 NCHBRN=NCHBRN-1
      IF (NCHBRN) 530,530,520
  520 IF (L-NCD) 480,650,650
  530 IF (NCD-NCDDM) 560,540,540
  540 ISKP(10)=20540
  550 IERR=1
      GO TO 999
  560 K8=K8+1
      NCD=NCD+1
      DO 570 L=1,3
  570 ATOMS(L,K8)=XAKT(L)
      ICD(NCD)=(((IANR*10+I)*10+J)*10+K)*100+ISYNR
      IF (ISKP(14)) 580,620,590
  580 IF (ISKP(14)+2) 650,620,700
  590 IF (IDQC-71) 610,600,600
  600 ISKP(10)=20600
      IERR=20
      GO TO 999
  610 IDQC=IDQC+1
      AIN(IDQC)=T1
      GO TO 650
  620 IF (ISKP(5)) 630,650,630
  630 T1=SQRT(T1)
      WRITE (NTOUT,640) NCD,AT(5,IANR),AT(6,IANR),ICD(NCD),
     1 XAKT,T1
  640 FORMAT (' ( ',I3,' ) ',2X,A4,A2,I11,5X,3F10.5,'   D =',F8.4)
  650 XAKT(3)=XAKT(3)+1.
      IF (ISKP(20)) 999,660,999
  660 CONTINUE
      XAKT(2)=XAKT(2)+1.
  670 CONTINUE
      XAKT(1)=XAKT(1)+1.
  680 CONTINUE
  690 CONTINUE
  700 CONTINUE
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPASCI
                          SUBROUTINE KPASCI
      INTEGER IAIN(72),CDS
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (IANR,K1),(IT(1),K2),(IT(2),K3),(IT(3),K4),(ISYNR,K5)
      EQUIVALENCE (AIN(1),IAIN(1),IVON),(AIN(2),IBIS)
      IF (NTYP-3) 10,270,350
   10 CALL FLES (CDS,ISKP(31),3H2IE,10Hc1 <,c2>?$)
      IF (ISKP(31)-1) 20,40,50
   20 ISKP(10)=30020
   30 IERR=16
      GO TO 999
   40 CDS(2)=CDS(1)
   50 NTRY=16
   60 NC=1
      CALL KPDEK
      IF (IERR) 999,70,999
   70 I1=K1
      I2=K2
      I3=K3
      I4=K4
      I5=K5
      NC=2
      CALL KPDEK
      IF (IERR) 999,80,999
   80 IF (NTYP-2) 90,140,90
   90 DO 130 I=I1,K1
      DO 130 J=I2,K2
      DO 130 K=I3,K3
      DO 130 L=I4,K4
      DO 130 M=I5,K5
      IF (NCD-NCDDM) 120,100,100
  100 ISKP(10)=30100
  110 IERR=1
      GO TO 999
  120 NCD=NCD+1
      ICD(NCD)=(((I*10+J)*10+K)*10+L)*100+M
  130 CONTINUE
      IF (NTYP-3) 999,999,400
  140 L1=IANR
      L2=IT(1)
      L3=IT(2)
      L4=IT(3)
      L5=ISYNR
      IF (NCD-NCDA) 999,150,150
  150 NTRY=32
      J=NCDA-1
      DO 260 IC=NCDA,NCD
      CALL KPDEK
      IF (I1-IANR) 160,160,250
  160 IF (IANR-L1) 170,170,250
  170 IF (I5-ISYNR) 180,180,250
  180 IF (ISYNR-L5) 190,190,250
  190 IF (I2-IT(1)) 200,200,250
  200 IF (IT(1)-L2) 210,210,250
  210 IF (I3-IT(2)) 220,220,250
  220 IF (IT(2)-L3) 230,230,250
  230 IF (I4-IT(3)) 240,240,250
  240 IF (IT(3)-L4) 260,260,250
  250 J=J+1
      ICD(J)=ICD(IC)
  260 CONTINUE
      GO TO 620
  270 CALL FLES (AIN,ISKP(31),3H2IE,10Hn1 <,n2>?$)
      IF (ISKP(31)-1) 280,290,300
  280 ISKP(10)=30280
      GO TO 30
  290 IBIS=IVON
  300 IF (IVON) 280,280,310
  310 IF (IBIS-IVON) 280,330,330
  320 ICD(IVON)=ICD(IBIS)
      IVON=IVON+1
  330 IBIS=IBIS+1
      IF (IBIS-NCD) 320,320,340
  340 J=IVON-1
      GO TO 620
  350 IF (NTYP-5) 360,490,500
  360 N=0
      NTRY=16
      IF (ISKP(14)) 390,380,370
  370 NA=ISKP(14)
      GO TO 400
  380 CALL FLES (AIN,ISKP(31),4H72IE,7Hcodes?$)
      NA=ISKP(31)
      IF (NA) 390,390,400
  390 ISKP(10)=030390
      GO TO 30
  400 IF (N-NA) 410,999,999
  410 N=N+1
      CDS(1)=IAIN(N)
      IF (N-NA) 420,450,450
  420 N=N+1
      IF (IAIN(N)) 430,440,440
  430 CDS(2)=-IAIN(N)
      GO TO 60
  440 N=N-1
  450 NC=1
      CALL KPDEK
      IF (IERR) 999,460,999
  460 IF (NCD-NCDDM) 480,470,470
  470 ISKP(10)=030470
      IERR=1
      GO TO 999
  480 NCD=NCD+1
      ICD(NCD)=(((IANR*10+IT(1))*10+IT(2))*10+IT(3))*100+ISYNR
      GO TO 400
  490 IBIS=0
      CALL FLES (IAIN,ISKP(31),3H2IE,10Hn1 <,n2>?$)
      GO TO 510
  500 IAIN(4)=1
      IAIN(5)=NAT
      CALL FLES (IAIN(3),ISKP(31),4HA2IE,17Hsymbol <,n1,n2>?$)
      CALL CNVTUP (IAIN(3),1,4)
      IVON=IAIN(4)
      IBIS=IAIN(5)
  510 IF (IBIS) 520,520,530
  520 IBIS=IVON
  530 IF (IVON-IBIS) 550,550,540
  540 IAIN(6)=IVON
      IVON=IBIS
      IBIS=IAIN(6)
  550 IVON=IVON*100000
      IBIS=IBIS*100000+99999
      I=NCDA-1
      J=I
      GO TO 610
  560 I=I+1
      IF (ICD(I)-IVON) 600,570,570
  570 IF (ICD(I)-IBIS) 580,580,600
  580 IF (NTYP-5) 590,610,590
  590 IANR=ICD(I)/100000
      AIN(6)=AT(5,IANR)
      CALL CNVTUP (IAIN(6),1,4)
      IF (IAIN(6) .EQ. IAIN(3)) GO TO 610
  600 J=J+1
      ICD(J)=ICD(I)
  610 IF (I-NCD) 560,620,620
  620 NCD=J
      K8=0
      K9=0
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880505--KPAVBR
                          SUBROUTINE KPAVBR
      INTEGER IAIN(72),CDS,IAINH(6)
      DIMENSION AINH(6)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1),IV1),(AIN(2),IV2),(AINH(1),IAINH(1))
      EQUIVALENCE (ATNAM,IATNAM)
      GO TO (10, 60, 120, 230,230,430,470),NTYP
   10 ISKP(32)=0
      CALL FLES (AIN,ISKP(31),5H3I3FE,
     1 22Horg,from,to,dx,dy,dz?$)
      IF (ISKP(32)-3) 20,30,30
   20 ISKP(10)=40020
      GO TO 990
   30 CDS(1)=IAIN(1)
      IZ1=IAIN(2)
      IZ2=IAIN(3)
      DO 40 I=1,3
   40 X(I,7)=AIN(I+3)
      NTRY=24
      NC=1
      CALL KPDEK
      IF (IERR) 999,50,999
   50 CALL KPADD
      GO TO 999
   60 ISKP(32)=0
      CALL FLES (AIN,ISKP(31),5H2I3FE,
     1 18Hfrom,to,ax,ay,az?$)
      IF (ISKP(32)-3) 70,80,80
   70 ISKP(10)=40070
      GO TO 990
   80 IZ1=IAIN(1)
      IZ2=IAIN(2)
      DO 90 I=1,3
      X(I,6)=AIN(I+2)
      X(I,1)=UR(I)
   90 X(I,7)=0.
      DO 110 I=1,3,2
      X1(1)=FLOAT(I-2)*X(1,6)
      DO 110 J=1,3,2
      X1(2)=FLOAT(J-2)*X(2,6)
      DO 110 K=1,3,2
      X1(3)=FLOAT(K-2)*X(3,6)
      DO 100 L=1,3
      X(L,7)=AMAX1(ABS(TRAINV(L,1)*X1(1)+TRAINV(L,2)*X1(2)+TRAINV(L,3)*
     1 X1(3)),X(L,7))
  100 CONTINUE
  110 CONTINUE
      GO TO 50
  120 CONST(19)=0.
      ISKP(32)=0
      AIN(5)=0.
      IF (ISKP(14)) 180,130,180
  130 CALL FLES (AIN,ISKP(31),5H3I2FE,
     1 18Horg,from,to,d,d2?$)
      IF (ISKP(32)) 140,140,150
  140 ISKP(10)=40140
      GO TO 990
  150 CDS(1)=IAIN(1)
      IZ1=IAIN(2)
      IZ2=IAIN(3)
      IF (AIN(4)-AIN(5)) 160,160,170
  160 CONST(20)=AIN(4)*AIN(4)
      DQ=AIN(5)
  170 CONST(20)=AIN(5)*AIN(5)
      DQ=AIN(4)
  180 DO 190 I=1,3
  190 X(I,7)=DQ*RK(I)
      DQ=DQ*DQ
      IF (NTYP-4) 200,290,290
  200 NTRY=26
      NC=1
      CALL KPDEK
      IF (IERR) 999,210,999
  210 DO 220 I=1,3
  220 X2(I)=X1(I)
      GO TO 50
  230 CONST(20)=0.
      IF (ISKP(14)) 260,240,260
  240 IAIN(6)=0
      AIN(7)=AMAX1(ZELLE(1),ZELLE(2),ZELLE(3))
      AIN(8)=0.
      ISKP(32)=0
      CALL FLES (AIN,ISKP(31),7H4IFI2FE,
     1 45Horg1,org2,tar1,tar2,dmax,ccentr,dcentr,dmin?$)
      IF (ISKP(32)) 250,250,260
  250 ISKP(10)=40250
      GO TO 990
  260 IZ1=IAIN(3)
      IZ2=IAIN(4)
      DQ=AIN(5)
      CONST(20)=AIN(8)*AIN(8)
      NCDE=NCD
      IV1=IV1*100000
      IV2=IV2*100000+99999
      CONST(19)=0.
      IF (IAIN(6)) 180,180,270
  270 CDS(1)=IAIN(6)
      NC=1
      NTRY=26
      CALL KPDEK
      IF (IERR) 999,280,999
  280 CONST(16)=X1(1)
      CONST(17)=X1(2)
      CONST(18)=X1(3)
      CONST(19)=AIN(7)*AIN(7)
      GO TO 180
  290 IK=NCDA-1
  300 IK=IK+1
      IF (NTYP-5) 330,350,310
  310 IF (NTYP-7) 330,320,330
  320 IF (IK-NCDE) 380,380,610
  330 IF (IK-NCDE) 360,360,340
  340 IF (NTYP-5) 999,999,440
  350 IF (IK-NCD) 360,360,999
  360 IF (IV1-ICD(IK)) 370,300,300
  370 IF (ICD(IK)-IV2) 380,300,300
  380 NTRY=42
      IC=IK
      NC=1
      CALL KPDEK
      IF (ISKP(5)) 390,410,390
  390 WRITE (NTOUT,400) IC,AT(5,IANR),AT(6,IANR),ICD(IC),
     1                                              X(1,1),X(2,1),X(3,1)
  400  FORMAT (' #',I4,' #   ',A4,A2,I11,
     1  ' ----',3F10.5,' --- Origin ---')
  410 DO 420 I=1,3
  420 X2(I)=X1(I)
      CALL KPADD
      IF (IERR) 999,300,999
  430 IAINH(6)=2
      AINH(5)=CONST(31)
      CALL FLES (IAINH,ISKP(31),5H4IFIE,
     1 29Horg1,org2,tar1,tar2,d,ncycl?$)
      GO TO 450
  440 IAINH(6)=IAINH(6)-1
      IF (IAINH(6)) 999,999,450
  450 DO 460 I=1,5
  460 IAIN(I)=IAINH(I)
      IAINH(1)=IAIN(3)
      IAINH(2)=IAIN(4)
      IAINH(3)=IAIN(1)
      IAINH(4)=IAIN(2)
      IAIN(6)=0
      AIN(8)=0.
      GO TO 260
  470 IAINH(5)=1
      IAINH(6)=NAT
      IAINH(4)=1
      AINH(3)=CONST(31)
      CALL FLES (IAINH,ISKP(31),6HAAF3IE,
     1 32Hsorg,star,dmax <,nghb,from,to>?$)
      IF (IAINH(5)) 500,500,480
  480 IF (IAINH(6)-NATDM) 490,490,500
  490 IF (IAINH(5)-IAINH(6)) 510,510,500
  500 ISKP(10)=40500
      GO TO 990
  510 CALL CNVTUP (IAINH,1,8)
      NCDE=NCD
      CONST(19)=0.
      CONST(20)=0.
      ISKP(28)=IAINH(4)
      ISKP(29)=IAINH(1)
      DO 520 I=1,3
  520 X(I,7)=AINH(3)*RK(I)
      DQ=AINH(3)*AINH(3)
      IK=NCDA-1
      GO TO 620
  530 IK=IK+1
      II=ICD(IK)/100000
      IF (II-IAINH(5)) 620,540,540
  540 IF (II-IAINH(6)) 550,550,620
  550 ATNAM=AT(5,II)
      CALL CNVTUP (ATNAM,1,4)
      IF (IATNAM .NE. IAINH(1)) GO TO 620
      IC=IK
      ISKP(30)=IC
      NC=1
      NTRY=42
      CALL KPDEK
      IF (IERR) 999,560,999
  560 DO 570 I=1,3
  570 X2(I)=X1(I)
      IF (ISKP(5)) 580,590,580
  580 WRITE (NTOUT,400) IC,AT(5,IANR),AT(6,IANR),ICD(IC),
     1                                              X(1,1),X(2,1),X(3,1)
  590 JJ=IAINH(5)-1
      GO TO 610
  600 JJ=JJ+1
      ATNAM=AT(5,JJ)
      CALL CNVTUP (ATNAM,1,4)
      IF (IATNAM .NE. IAINH(2)) GO TO 610
      IZ1=JJ
      IZ2=JJ
      CALL KPADD
      IF (IERR) 999,610,999
  610 IF (JJ-IAINH(6)) 600,620,620
  620 IF (IK-NCDE) 530,999,999
  990 IERR=16
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880531--KPAWTB
                          SUBROUTINE KPAWTB
      INTEGER DB2210,ICDS(7),INPPAR(8)
      DIMENSION              RNPPAR(8)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (CDS(1),ICDS(1)),(AIN(72),IDQC),(INPPAR(1),RNPPAR(1))
      IF (ISKP(14)) 80,10,80
   10 I=DB2210(0)
      INPPAR(2)=0
      RNPPAR(5)=3.
      RNPPAR(6)=.0001
      RNPPAR(7)=0.
      RNPPAR(8)=181.
      CALL FLES (INPPAR,ISKP(31),5H4I4FE,
     1 42Hc1,c2,n1,n2,dmax <,dmin <,amin <,amax>>>?$)
      IF (ISKP(31)-4) 20,30,20
   20 ISKP(10)=390020
      IERR=16
      GO TO 999
   30 IF (RNPPAR(5)-RNPPAR(6)) 40,50,50
   40 CDS(6)=RNPPAR(6)
      RNPPAR(6)=RNPPAR(5)
      RNPPAR(5)=CDS(6)
   50 DO 60 I=1,6
   60 ICDS(I)=INPPAR(I)
      IF (ICDS(2)) 80,70,80
   70 ICDS(2)=ICDS(1)
   80 NCDSV=NCD
      NCDASV=NCDA
      ISKP14=ISKP(14)
      NTYPS=NTYP
      K8SV=K8
      ISKP(14)=1
      NCDA=NCD+1
      NCHOPT=0
      IF (NTYP-1) 120,90,120
   90 IF (RNPPAR(7)) 100,120,100
  100 IF (NCDSV-NCDASV) 120,110,110
  110 NCHOPT=1
  120 CONTINUE
      NTRY=16
      NC=1
      CALL KPDEK
      IF (IERR) 990,130,990
  130 I1=IANR
      I2=IT(1)
      I3=IT(2)
      I4=IT(3)
      I5=ISYNR
      NC=2
      IF (IABS(ICDS(2))-NATDM) 140,140,150
  140 IF (ICDS(2)) 150,150,145
  145 IANR=ICDS(2)
      GO TO 160
  150 CALL KPDEK
      IF (IERR) 990,160,990
  160 K1=MAX0(IANR,I1)
      K2=MAX0(IT(1),I2)
      K3=MAX0(IT(2),I3)
      K4=MAX0(IT(3),I4)
      K5=MAX0(ISYNR,I5)
      IZ1=ICDS(3)
      IZ2=ICDS(4)
      DMAX=CDS(5)
      DMINQ=CDS(6)*CDS(6)
      DO 570 J1=I1,K1
      DO 570 J2=I2,K2
      DO 570 J3=I3,K3
      DO 570 J4=I4,K4
      DO 570 J5=I5,K5
      NCD=NCDA-1
      K8=K8SV
      NC=1
      ICDS(NC)=(((J1*10+J2)*10+J3)*10+J4)*100+J5
      IDQC=0
      DQ=DMAX
      NTYP=3
      CALL KPAVBR
      ICDS(7)=NCD
      IPOI=0
      IPOIS=0
      ITABP=NCDA-1
      ITABS=ITABP
  170 IF (ITABP-NCD) 180,240,240
  180 ITABP=ITABP+1
      IPOI=IPOI+1
      TEMP=AIN(IPOI)
      IF (TEMP-DMINQ) 170,190,190
  190 ITM1=ICD(ITABP)
      ITABS=ITABS+1
      IPOIS=IPOIS+1
      JH=IPOIS
      KH=ITABS
      GO TO 210
  200 AIN(JH+1)=AIN(JH)
      ICD(KH+1)=ICD(KH)
  210 JH=JH-1
      KH=KH-1
      IF (JH) 230,230,220
  220 IF (TEMP-AIN(JH)) 200,230,230
  230 AIN(JH+1)=TEMP
      ICD(KH+1)=ITM1
      GO TO 170
  240 IF (NTYPS-3) 250,990,250
  250 NC=1
      IF (DB2210(4)) 990,260,990
  260 WRITE (NTOUT,270)
  270 FORMAT (' ')
      WRITE (NTOUT,280)
  280 FORMAT (' +',18(1H-),'+',10(1H-),'+',11(1H-),'+',32(1H-),'+')
      WRITE (NTOUT,290) AT(5,J1),AT(6,J1),ICDS(NC),(X(JH,NC),JH=1,3)
  290 FORMAT (
     1 ' I Distance / Angle I ',2A4,' I',I10 ,' I ',3F10.6,' I')
      WRITE (NTOUT,280)
      NC=2
      NTRY=42
      IC=NCDA-1
      IPOI=0
      GO TO 360
  300 IC=IC+1
      IPOI=IPOI+1
      IF (NCHOPT) 310,330,310
  310 ICDIC=ICD(IC)
      DO 320 JH=NCDASV,NCDSV
      IF (ICD(JH)-ICDIC) 320,360,320
  320 CONTINUE
  330 CALL KPDEK
      ATOMS(1,IC)=X1(1)
      ATOMS(2,IC)=X1(2)
      ATOMS(3,IC)=X1(3)
      TEMP=SQRT(AIN(IPOI))
      AIN(IPOI)=TEMP
      IF (DB2210(1)) 990,340,990
  340 WRITE (NTOUT,350) TEMP,AT(5,IANR),AT(6,IANR),ICD(IC),
     1                                              (X(JH,NC),JH=1,3)
  350 FORMAT (' I    =',F7.4,' A    I ',2A4,' I',I10,' I ',
     1 3F10.6,' I')
      IF (ISKP(20)) 990,360,990
  360 IF (IC-ITABS) 300,370,370
  370 IF (NTYPS-2) 550,380,570
  380 IF (ITABS-NCDA-1) 550,390,390
  390 NC=1
      NTRY=26
      CALL KPDEK
      IF (DB2210(1)) 990,400,990
  400 WRITE (NTOUT,280)
      NTRY=32
      IPOI=0
      I=NCDA-1
      GO TO 540
  410 IPOI=IPOI+1
      JPOI=IPOI
      NC=2
      IC=I
      CALL KPDEK
      ICDS(2)=IANR
      J=I
      GO TO 530
  420 JPOI=JPOI+1
      TEMP=AIN(IPOI)*AIN(JPOI)
      IF (TEMP) 530,530,430
  430 NC=3
      IC=J
      CALL KPDEK
      TEMP=((ATOMS(1,I)-X1(1))*(ATOMS(1,J)-X1(1))
     1     +(ATOMS(2,I)-X1(2))*(ATOMS(2,J)-X1(2))
     2     +(ATOMS(3,I)-X1(3))*(ATOMS(3,J)-X1(3)))/TEMP
      IF (TEMP-1.) 450,440,440
  440 TEMP=0.
      GO TO 480
  450 IF (TEMP+1.) 460,460,470
  460 TEMP=180.
      GO TO 480
  470 CONTINUE
      TEMP=ACOS(TEMP)/CONST(3)
  480 IF (TEMP-RNPPAR(7)) 530,490,490
  490 IF (TEMP-RNPPAR(8)) 500,500,530
  500 IF (DB2210(1)) 990,510,990
  510 WRITE (NTOUT,520) TEMP,AT(5,ICDS(2)),AT(6,ICDS(2)),AT(5,IANR),
     1 AT(6,IANR),ICD(I),ICD(J)
  520 FORMAT (' I  =',F7.2,'  Grad  I ',2A4,' I  ',2A4,' I',
     1 4X,I9,5X,I9,5X,'I')
      IF (ISKP(20)) 990,530,990
  530 J=J+1
      IF (J-ITABS) 420,420,540
  540 I=I+1
      IF (I-ITABS) 410,550,550
  550 IF (DB2210(1)) 990,560,990
  560 WRITE (NTOUT,280)
  570 CONTINUE
  990 NCD=NCDSV
      NCDA=NCDASV
      ISKP(14)=ISKP14
      K8=K8SV
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880610--KPBILF
                          SUBROUTINE KPBILF
      INTEGER TITEL
      DIMENSION IAIN(72),KDOT(10),IKDOT(10),ITYPT(11),AIPK(400)
      DIMENSION IOPEN(10)
      CHARACTER*12 IFILNM
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      COMMON /TFKTRN/ ANTFKT(9,200),NTFKT,NTFDM
      SAVE IOPEN,IOPENP
      EQUIVALENCE (AIN(1),IAIN(1)),(IPK(1),AIPK(1))
      DATA IKDOT/4,8,8,8,5,7,11,11,11,11/
      DATA KDOT/4HPK  ,4HVB  ,4HVBS ,4HVBR ,4HBA  ,4HBT  ,4HPPFL,4HVEH ,
     1 4HVEU ,4HVE  /
       DATA IBLK,IAPO/4H    ,4H'   /
      DATA ITYPT/ 5,13,  9, 8, 15, 4,  6, 14,3,  2,  0/
       DATA IOPEN/10*0/,IOPENP/0/,IFILNM/'FT4XF001.DAT'/
      IF (NTYP-10) 10,20,10
   10 CALL DB2338 (NTBILF,I)
      IF (I) 990,11,990
   11 CONTINUE
      IF (IOPENP) 14,14,12
C                            Teste, ob schon offen.
   12 DO 13 I=1,IOPENP
      IF (IOPEN(I)-NTBILF) 13,20,13
   13 CONTINUE
C                            Noch nicht auf, wenn hier.
   14 IOPENP=IOPENP+1
      IOPEN(IOPENP)=NTBILF
      IFILNM(4:4)=CHAR(NTBILF+8)
      OPEN (NTBILF,FORM='FORMATTED',STATUS='UNKNOWN',FILE=IFILNM)
   20 NTYPS=NTYP
      IF (NTYPS-15) 30,30,590
   30 GO TO (40,60,260,290,320,380,400,410,510,520,530,550,360,240,460),
     1 NTYPS
   40 CALL FLES (AIN,ISKP(31),4H20AE,13HKommando(s)?$)
      WRITE (NTBILF,50) (AIN(I),I=1,20)
   50 FORMAT (20A4)
      GO TO 999
   60 JPKM=0
      I=0
      JPKP=1
      NANZ=0
   70 I=I+1
      JPKP=JPKP+NANZ
      IF(JPKP-IPKP) 90,80,80
   80 IF (NTYP) 610,610,990
   90 N=IPK(JPKP)
      IF(N-6) 100,110,100
  100 NANZ=IKDOT(N)
      GO TO 120
  110 K=IPK(JPKP+6)
      NANZ=7+K
  120 IF (N-5) 130,150,170
  130 IF (N-1) 135,135,138
  135 WRITE (NTBILF,140) KDOT(1),(IPK(JPKP+J),J=1,3)
      GO TO 70
  138 WRITE (NTBILF,140) KDOT(N),(IPK(JPKP+J),J=1,4),
     1 (AIPK(JPKP+J),J=5,7)
  140 FORMAT (A4,4I4,3F6.2)
      GO TO 70
  150 WRITE (NTBILF,160) KDOT(N),IPK(JPKP+1),(AIPK(JPKP+J),J=2,4)
  160 FORMAT (A4,I9,2F6.2,F6.3)
      GO TO 70
  170 IF (N-7) 180,200,220
  180 WRITE (NTBILF,190) KDOT(N),(IPK(JPKP+J),J=1,2),
     1 (AIPK(JPKP+J),J=3,5),(IPK(JPKP+J+6),J=1,K),IAPO
  190 FORMAT (A4,2I9,2F6.2,F6.3,1X,1H',12A4)
      GO TO 70
  200 WRITE (NTBILF,210) KDOT(N),(IPK(JPKP+J),J=1,3),
     1 (AIPK(JPKP+J),J=4,9),IPK(JPKP+10)
  210 FORMAT (A4,3I9,6F7.2,I4)
      GO TO 70
  220 WRITE (NTBILF,230) KDOT(N),(IPK(JPKP+J),J=1,4),
     1 (AIPK(JPKP+J),J=5,6),(IPK(JPKP+J),J=7,8),(AIPK(JPKP+J),J=9,10)
  230 FORMAT (A4,4I4,2F6.2,2I4,2F6.2)
      GO TO 70
  240 WRITE (NTBILF,250) UR
  250 FORMAT ('PT ',3F10.5,' / KUP')
      IF (NTYP) 610,610,990
  260 CALL KPORTN
      DO 280 I=1,3
      WRITE (NTBILF,270)  I,CDS(I)
  270 FORMAT ('DK',I2,F8.2)
  280 CONTINUE
      IF (NTYP) 610,610,990
  290 IF(NCDA-NCD) 300,300,80
  300 WRITE (NTBILF,310) (ICD(I),I=NCDA,NCD)
  310 FORMAT ('ACIM',7I9)
      IF (NTYP) 610,610,990
  320 K=1
      DO 340 I=2,18
      IF (TITEL(I)-IBLK) 330,340,330
  330 K=I
  340 CONTINUE
      WRITE (NTBILF,350) (TITEL(I),I=1,K),IAPO
  350 FORMAT ('T ''',19A4)
      IF (NTYP) 610,610,990
  360 WRITE (NTBILF,370) ZELLE
  370 FORMAT ('Z ',3F10.5,3F10.4)
      IF (NTYP) 610,610,990
  380 TEMP=HOE*O8
      WRITE (NTBILF,390)(CONST(I),I=8,12),O8,TEMP
  390 FORMAT ('ZF',2F7.2,F6.2,' / UR',2F7.2,' / F',F7.2,' / H',F10.2)
      IF (NTYP) 610,610,990
  400 REWIND NTBILF
      GO TO 990
  410 I=0
      GO TO 440
  420 I=I+1
      WRITE (NTBILF,430) AT(5,I),AT(6,I),(AT(J,I),J=1,4)
  430 FORMAT ('ATOM ''',A4,3H' ',A4,1H',3F10.6,F5.2)
  440 IF (I-NAT) 420,450,450
  450 IF (NTYP) 610,610,990
  460 I=0
      GO TO 490
  470 WRITE (NTBILF,480) (ANTFKT(J,I),J=1,9)
  480 FORMAT ('TF ',A4,',',A4,',',6F9.6,F4.0)
  490 I=I+1
      IF (I-NTFKT) 470,470,500
  500 IF (NTYP) 610,610,990
  510 IF (ISKP(18)) 513,513,511
  511 WRITE (NTBILF,512) ISKP(16),ISKP(17)
  512 FORMAT ('HMS ''',2A4,'''')
      GO TO 514
  513 ISKP(14)=NTBILF
      CALL KPSYOU
  514 ISKP(14)=0
      IF (NTYP) 610,610,990
  520 CALL FLES (NTBILF,ISKP(31),2HIE,4HNr?$)
      GO TO 999
  530 NANZ=1
      CALL FLES (NANZ,ISKP(31),2HIE,6HAnz.?$)
      DO 540 I=1,NANZ
  540 BACKSPACE NTBILF
      GO TO 999
  550 IAIN(1)=NCDA
      IAIN(2)=NCD
      CALL FLES (IAIN,ISKP(31),3H2IE,25Hvon,bis (Nrn Codeliste)?$)
      NTRY=44
      NC=1
      IC=IAIN(1)-1
      GO TO 580
  560 IC=IC+1
      CALL KPDEK
      WRITE (NTBILF,570) X2,AT(5,IANR),AT(6,IANR)
  570 FORMAT (3F15.6,4X,2A4)
  580 IF (IC-IAIN(2)) 560,999,999
  590 ITYP=0
      NTYP=0
      WRITE (NTBILF,600)
  600 FORMAT ('NTSO')
  610 ITYP=ITYP+1
      NTYPS=ITYPT(ITYP)
      IF (NTYPS) 620,620,30
  620 WRITE (NTBILF,630) NTIN
  630 FORMAT ('TSO / EAE',I3)
      NTYP=NTYPS
  990 CALL FLES (AIN,ISKP(31),1HE,2H?$)
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880408--KPDEK
                          SUBROUTINE KPDEK
      INTEGER CDS
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      NTRYS=NTRY
      IF (NTRYS-32) 30,10,10
   10 NTRYS=NTRYS-32
      ITEMP=ICD(IC)
      IANR=ITEMP/100000
      ITEMP=ITEMP-IANR*100000
      IF (ITEMP-55501) 20,90,20
   20 IT(1)=ITEMP/10000
      ITEMP=ITEMP-IT(1)*10000
      IT(2)=ITEMP/1000
      ITEMP=ITEMP-IT(2)*1000
      IT(3)=ITEMP/100
      ISYNR=ITEMP-IT(3)*100
      GO TO 150
   30 IF (NTRYS-16) 150,40,40
   40 NTRYS=NTRYS-16
      IANR=CDS(NC)
      IF (IANR) 50,80,70
   50 IANR=-IANR
      IF (IANR-NCDDM) 60,60,80
   60 IANR=ICD(IANR)
      CDS(NC)=IANR
      IF (IANR) 80,80,70
   70 IF (IANR-NATDM) 90,90,110
   80 ISKP(10)=50080
      IERR=9
      IANR=1
   90 IT(1)=5
      IT(2)=5
      IT(3)=5
      ISYNR=1
      IF (NTRYS-8) 180,100,100
  100 X(1,NC)=AT(1,IANR)
      X(2,NC)=AT(2,IANR)
      X(3,NC)=AT(3,IANR)
      GO TO 170
  110 ITEMP=IANR/100
      ISYNR=IANR-100*ITEMP
      IF (ISYNR) 80,80,120
  120 IF (ISYNR-NSYMDM) 130,130,80
  130 IANR=ITEMP/10
      IT(3)=ITEMP-10*IANR
      ITEMP=IANR/10
      IT(2)=IANR-10*ITEMP
      IANR=ITEMP/10
      IT(1)=ITEMP-10*IANR
      IF (IANR) 80,80,140
  140 IF (IANR-NATDM) 150,150,80
  150 IF (NTRYS-8) 180,160,160
  160 X(1,NC)=SYM(1,ISYNR)+FLOAT(IT(1)-5) + SYM( 2,ISYNR)*AT(1,IANR)
     1 + SYM( 3,ISYNR)*AT(2,IANR) + SYM( 4,ISYNR)*AT(3,IANR)
      X(2,NC)=SYM(5,ISYNR)+FLOAT(IT(2)-5) + SYM( 6,ISYNR)*AT(1,IANR)
     1 + SYM( 7,ISYNR)*AT(2,IANR) + SYM( 8,ISYNR)*AT(3,IANR)
      X(3,NC)=SYM(9,ISYNR)+FLOAT(IT(3)-5) + SYM(10,ISYNR)*AT(1,IANR)
     1 + SYM(11,ISYNR)*AT(2,IANR) + SYM(12,ISYNR)*AT(3,IANR)
  170 NTRYS=NTRYS-8
  180 IF (NTRYS-4) 220,190,190
  190 DO 200 I=1,3
  200 X1(I)=X(I,NC)-UR(I)
      DO 210 I=1,3
      X2(I)=TRA(I,1)*X1(1)+TRA(I,2)*X1(2)+TRA(I,3)*X1(3)
  210 CONTINUE
      NTRYS=NTRYS-4
  220 IF (NTRYS-2) 250,230,230
  230 DO 240 I=1,3
      X1(I)=DG(I,1)*X(1,NC)+DG(I,2)*X(2,NC)+DG(I,3)*X(3,NC)
  240 CONTINUE
      NTRYS=NTRYS-2
  250 IF (NTRYS-1) 999,260,260
  260 CDS(NC)=(((IANR*10+IT(1))*10+IT(2))*10+IT(3))*100+ISYNR
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPEFIT
                          SUBROUTINE KPEFIT
      DIMENSION SUM(10),A(3,3),R(3,3),V(3),IAIN(72)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1),IVON),(AIN(2),IBIS),(AIN(3),SUM(1))
      EQUIVALENCE (AIN(13),A(1,1)),(AIN(22),R(1,1)),(AIN(31),V(1))
      EQUIVALENCE (SYMBL,ISYMBL)
      DATA IBLANK/4H    /
      IF (ISKP(14)) 30,10,30
   10 IF (NTYP-2) 20,20,80
   20 IVON=1
      IBIS=NAT
      CALL FLES (AIN,ISKP(31),3H2IE,9Hvon,bis?$)
   30 IF (IVON) 60,60,40
   40 IF (IBIS-NATDM) 50,50,60
   50 IF (IBIS-IVON) 60,130,130
   60 ISKP(10)=400060
   70 IERR=16
      GO TO 999
   80 DO 90 I=51,57,3
      IAIN(I)=IBLANK
      IAIN(I+1)=1
      IAIN(I+2)=NAT
   90 CONTINUE
      CALL FLES (AIN(51),ISKP(31),10HA2IA2IA2IE,
     1 26Hs1,v1,b1, s2,v2,b2, ... ?$)
      NANZ=0
      DO 100 I=51,57,3
      IF (IAIN(I) .EQ. IBLANK) GO TO 110
      NANZ=I
  100 CONTINUE
  110 IF (NANZ) 120,120,130
  120 ISKP(10)=400120
      GO TO 70
  130 NC=1
      NTRY=2
      DO 140 I=1,10
  140 SUM(I)=0.
      IPCNT=0
      IF (NTYP-2) 150,170,170
  150 IANR=IVON-1
      GO TO 260
  160 IANR=IANR+1
      X(1,1)=AT(1,IANR)
      X(2,1)=AT(2,IANR)
      X(3,1)=AT(3,IANR)
      GO TO 250
  170 IC=NCDA-1
      GO TO 270
  180 IC=IC+1
      NTRY=32
      CALL KPDEK
      IF (NTYP-2) 220,220,190
  190 SYMBL=AT(5,IANR)
      DO 210 I=51,NANZ,3
      IF (ISYMBL .NE. IAIN(I)) GO TO 210
      IF (IANR-IAIN(I+1)) 210,200,200
  200 IF (IANR-IAIN(I+2)) 240,240,210
  210 CONTINUE
      GO TO 270
  220 IF (IANR-IVON) 270,230,230
  230 IF (IANR-IBIS) 240,240,270
  240 NTRY=10
  250 IPCNT=IPCNT+1
      CALL KPDEK
      GEW=AT(4,IANR)
      SUM(1)=SUM(1)+X1(1)*GEW
      SUM(2)=SUM(2)+X1(2)*GEW
      SUM(3)=SUM(3)+X1(3)*GEW
      SUM(4)=SUM(4)+X1(1)*X1(1)*GEW
      SUM(5)=SUM(5)+X1(1)*X1(2)*GEW
      SUM(6)=SUM(6)+X1(1)*X1(3)*GEW
      SUM(7)=SUM(7)+X1(2)*X1(2)*GEW
      SUM(8)=SUM(8)+X1(2)*X1(3)*GEW
      SUM(9)=SUM(9)+X1(3)*X1(3)*GEW
      SUM(10)=SUM(10)+GEW
      IF (NTYP-2) 260,270,270
  260 IF (IANR-IBIS) 160,280,280
  270 IF (IC-NCD) 180,280,280
  280 IF (IPCNT-3) 290,300,300
  290 ISKP(10)=400290
      GO TO 70
  300 A(1,1)=SUM(1)*SUM(1)/SUM(10)-SUM(4)
      A(1,2)=SUM(1)*SUM(2)/SUM(10)-SUM(5)
      A(1,3)=SUM(1)*SUM(3)/SUM(10)-SUM(6)
      A(2,2)=SUM(2)*SUM(2)/SUM(10)-SUM(7)
      A(2,3)=SUM(2)*SUM(3)/SUM(10)-SUM(8)
      A(3,3)=SUM(3)*SUM(3)/SUM(10)-SUM(9)
      A(2,1)=A(1,2)
      A(3,1)=A(1,3)
      A(3,2)=A(2,3)
      CALL KPEIGN (A,R,3)
      IK=1
      IG=1
      DO 340 I=2,3
      IF (ABS(A(IK,IK))-ABS(A(I,I))) 320,320,310
  310 IK=I
  320 IF (ABS(A(IG,IG))-ABS(A(I,I))) 330,340,340
  330 IG=I
  340 CONTINUE
      U=0.
      DO 350 I=1,3
      T1=R(I,IK)
      V(I)=T1
  350 U=U+T1*T1
      IF (U) 360,360,370
  360 ISKP(10)=400360
      IERR=6
      GO TO 999
  370 U=SQRT(U)
      DO 380 I=1,3
  380 V(I)=V(I)/U
      D=(V(1)*SUM(1)+V(2)*SUM(2)+V(3)*SUM(3))/SUM(10)
      DO 390 I=1,3
  390 UR(I)=(RG(1,I)*V(1)+RG(2,I)*V(2)+RG(3,I)*V(3))*D
      U=0.
      DO 400 I=1,3
      T1=R(I,IG)
      U=U+T1*T1
  400 X1(I)=T1
      IF (U) 360,360,410
  410 U=SQRT(U)
      DO 420 I=1,3
      J=ID2(I)
      K=ID2(J)
      DREH(3,I)=V(I)
  420 DREH(2,I)=(X1(J)*V(K)-X1(K)*V(J))/U
      DO 430 I=1,3
      J=ID2(I)
      K=ID2(J)
  430 DREH(1,I)=DREH(2,J)*V(K)-DREH(2,K)*V(J)
      NTYP=3
      CALL KPK
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD870430--KPEIGN
                      SUBROUTINE KPEIGN (A,B,N)
      DIMENSION A(N,N),B(N,N)
      FLN=N
      DO 20 I=1,N
      DO 10 J=1,N
   10 B(I,J)=0.
   20 B(I,I)=1.
      GEN=.1E-8
      ANORM=0.
      IA=N-1
      DO 30 I=1,IA
      IB=I+1
      DO 30 J=IB,N
      TEMP=A(I,J)
   30 ANORM=ANORM+2.*TEMP*TEMP
      IF(ANORM) 999,999,40
   40 ANORM=SQRT(2.*ANORM)
      TEST=ANORM*GEN/FLN
      IND=0
      THR=ANORM
   50 THR=THR/FLN
   60 J=1
   70 K=J+1
   80 IF(ABS(A(J,K))-THR)  160,160,90
   90 IND=1
      X=(A(J,J)-A(K,K))*.5/A(J,K)
      TA =SIGN(1.,X)/(ABS(X)+SQRT(1.+X*X))
      CO =1./SQRT(1.+TA *TA )
      SI =TA *CO
      TEMP=A(J,K)*TA
      A(J,J)=A(J,J)+TEMP
      A(K,K)=A(K,K)-TEMP
      A(J,K)=0.
      TAU=SI /(1.+CO )
      DO 150 IR=1,N
      IF(IR-J)  100,140,110
  100 X=A(IR,J)
      Y=A(IR,K)
      A(IR,J)=X+SI *(Y-TAU*X)
      A(IR,K)=Y-SI *(X+TAU*Y)
      GOTO 140
  110 IF(IR-K) 120,140,130
  120 X=A(J,IR)
      Y=A(IR,K)
      A(J,IR)=X+SI *(Y-TAU*X)
      A(IR,K)=Y-SI *(X+TAU*Y)
      GOTO 140
  130 X=A(J,IR)
      Y=A(K,IR)
      A(J,IR)=X+SI *(Y-TAU*X)
      A(K,IR)=Y-SI *(X+TAU*Y)
  140 X=B(IR,J)
      B(IR,J)=X*CO +SI *B(IR,K)
  150 B(IR,K)=-SI *X+CO *B(IR,K)
  160 IF(K-N) 170,180,170
  170 K=K+1
      GOTO 80
  180 IF(J-N+1) 190,200,190
  190 J=J+1
      GOTO 70
  200 IF (IND) 220,220,210
  210 IND=0
      GOTO 60
  220 IF(THR-TEST) 999,999,50
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPERR
                          SUBROUTINE KPERR
      DIMENSION KPPGM(62),KOM(21)
      INTEGER TEXT(134)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      DATA KPPGM/4HMAIN,4HADD ,4HASCI,4HAVBR,4HDEK ,4HERR ,4HEXPU,
     1 4HGTY ,4HGE01,4HGE02,4HK   ,4HLPK ,4HO   ,4HORTN,4HPRIM,4HPST ,
     2 4HP2A ,4HP3A ,4HVBU ,4HZ   ,4HSYDC,4HSYOU,4HORTP,4HSRT ,4HGE03,
     3 4HIDL ,4HXDAT,4HPPFL,4HFKTR,4HB800,4HHMS ,4HLABL,4HLENT,4HMACR,
     4 4HBSCH,4HPKED,4HBILF,4HGTYA,4HAWTB,4HEFIT,4HEIGN,4HSPG ,4HZNTR,
     5 4HTSY ,4HLCD ,4HPLTO,4HMINO,4HRPSY,4HSPVV,4HPNCD,4HEHND,4HGNKO,
     6 4HGNZL,4HGOML,4HTFHN,4HGUMN,4HZK  ,4HFNIN,4HGNSX,4HDRMO,4HBDGB,
     7 4H..../
      DATA KOM/9,14,21,28,35,40,48,54,58,64,70,78,82,90,96,102,
     1 113,120,127,131,135/
      DATA TEXT/4HIlle,4Hgal ,4Hcall,4H of ,4Herro,4Hr ro,4Hutin,
     1   4He.  ,4HTabl,4He of,4H cod,4Hes f,4Hull.,4HTabl,4He fo,
     2   4Hr pa,4Hrame,4Hters,4H ful,4Hl.  ,4HTabl,4He fo,4Hr sy,
     3   4Hmmet,4Hries,4H ful,4Hl.  ,4HAtom,4H num,4Hbre ,4Hout ,
     4   4Hof r,4Hange,4H.   ,4HMiss,4Hing ,4Hsymm,4Hetri,4Hes. ,
     5   4HZero,4H vec,4Htor ,4Hor v,4Hecto,4Hrs c,4Hopla,4Hnar.,
     6   4HIlle,4Hgal ,4Hnumb,4Hre f,4Hor a,4Hxes.,4HMiss,4Hing ,
     7   4Hatom,4Hs.  ,4HCode,4H or ,4Hadre,4Hss i,4Hnval,4Hid. ,
     8   4HCell,4H con,4Hstan,4Hts i,4Hnval,4Hid. ,4HTabl,4He fo,
     9   4Hr pl,4Hot c,4Homma,4Hnds ,4Hfull,4H.   ,4HMiss,4Hing ,
     A   4Hcode,4Hs.  ,4HSize,4H of ,4Hstic,4Hk bi,4Hgger,4H tha,
     B   4Hn at,4Hom. ,4HUnkn,4Hown ,4Hlatt,4Hice ,4Htype,4H.   ,
     C   4HPoin,4Ht do,4Hes n,4Hot e,4Hxist,4H.   ,4HComm,4Hand ,
     D   4Hpara,4Hmete,4Hrs i,4Hncom,4Hplet,4He or,4H inv,4Halid,
     E   4H.   ,4HAtom,4H out,4H of ,4Hdraw,4Hing ,4Hfiel,4Hd.  ,
     F   4HImpo,4Hssib,4Hle t,4Ho sc,4Hale ,4Hmode,4Hl.  ,4HList,
     G   4H is ,4Hempt,4Hy.  ,4HStac,4Hk ov,4Herfl,4How. /
   10 CALL FLES (AIN,AIN,1HK,AIN)
   20 IF (IERR) 40,40,30
   30 IF (IERR-20) 50,50,40
   40 NST=1
      NZ=5
      GO TO 60
   50 NST=KOM(IERR)
      NZ=KOM(IERR+1)-1
   60 IPGM=ISKP(10)/10000
      IPGNR=ISKP(10)-10000*IPGM
      WRITE (NTOUT,70) KPPGM(IPGM),IPGNR,(TEXT(J),J=NST,NZ)
   70 FORMAT (' KP',A4,I4,' - ',20A4)
      IERR=0
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPEXPU
                          SUBROUTINE KPEXPU
      INTEGER ATMSYM
      DIMENSION CTAB(30),STAB(30),IAT(6,200),IAIN(72),VQ(400),TBUF(3)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPPOI,NPDIM,NPLST(100)
      EQUIVALENCE (AIN(1),IAIN(1))
      EQUIVALENCE (AT(1,1),IAT(1,1)),(IPK(1),VQ(1))
      EQUIVALENCE (X(1,1),XK),(X(2,1),YK)
      SAVE NST,TBUF,IBLANK,CTAB,STAB
      DATA NST/0/,TBUF/0.,1.,0./,IBLANK/4H    /
      NTYPS=NTYP
      GO TO (10,1260,1270,1270), NTYP
   10 K8=0
      NTRY=44
      NC=1
      GO TO 40
   20 K9=K9+1
      IC=K9
      CALL KPDEK
      DO 30 I=1,3
   30 ATOMS(I,K9)=X2(I)
   40 IF (NCD-K9) 50,50,20
   50 IF (ISKP(7)) 70,60,70
   60 ISKP(25)=0
   70 IF (ISKP(25)) 80,90,80
   80 CALL KPWPLT (TBUF(2),14)
   90 IF (NCDA-NCD) 100,100,9990
  100 TEMX=ATOMS(3,NCDA)
      TEMP=ATOMS(3,NCD)-TEMX
      IF (TEMP) 120,110,120
  110 CONST(26)=0.
      CONST(25)=(CONST(23)+CONST(24))*.5
      GO TO 130
  120 CONST(26)=(CONST(24)-CONST(23))/TEMP
      CONST(25)=CONST(23)-CONST(26)*TEMX
  130 IC1=NCD+1
  140 IF (ISKP(25)) 150,160,150
  150 CALL KPWPLT (TBUF(2),17)
  160 IF (IC1-NCDA) 970,970,170
  170 IC1=IC1-1
      IC1CD=ICD(IC1)
      IZ1=IC1CD/100000
      IF (ISKP(20)) 9990,210,9990
  180 IF (ISKP(25)) 190,160,190
  190 IF (IPKFLG) 200,140,200
  200 CALL KPWPLT (TBUF,17)
      TEMP=X(1,2)+T(1)
      GO TO 420
  210 IC=IC1
      IPKFLG=0
      X(3,1)=ATOMS(3,IC1)
      TEMPFK=HOE/(HOE-X(3,1))
      XK=ATOMS(1,IC1)*TEMPFK
      YK=ATOMS(2,IC1)*TEMPFK
      TEMP=AT(4,IZ1)*TEMPFK*FKGL
      ATMSYM=IAT(5,IZ1)
      T(2)=CONST(26)*ATOMS(3,IC1)+CONST(25)
      T(1)=T(2)/O8
      X(1,2)=TEMP
      IPKPNT=1
      GO TO 580
  220 IPLTBF=IPK(IPKPNT)
      IF (IPLTBF-1) 510,300,230
  230 IF (IPLTBF-8) 510,270,240
  240 IF (IPLTBF-11) 270,250,250
  250 ISKP(10)=70250
      WRITE (NTOUT,260) IPLTBF
  260 FORMAT (' KPEXPU0260 - Ill. Plotbefehl.',I12)
      IERR=16
      GO TO 9990
  270 IF (IZ1-IPK(IPKPNT+7)) 540,280,280
  280 IF (IZ1-IPK(IPKPNT+8)) 290,290,540
  290 CALL KPVLEK (IPKPNT)
      GO TO 140
  300 INC=4
      IF (IZ1-IPK(IPKPNT+1)) 570,320,310
  310 IF (IZ1-IPK(IPKPNT+2)) 320,320,570
  320 IF (NPPOI) 360,360,330
  330 DO 350 I=1,NPPOI,2
      IF (IC1CD-NPLST(I)) 350,340,350
  340 IF (NPLST(I+1)) 350,570,350
  350 CONTINUE
  360 NSTPKT=IPK(IPKPNT+3)
      NSTPBF=IABS(NSTPKT)
      IF (NSTPBF-NST) 370,390,370
  370 NST=NSTPBF
      F=CONST(2)/FLOAT(NST)
      DO 380 I=1,NST
      TEMX=FLOAT(I)*F
      CTAB(I)=COS(TEMX)
  380 STAB(I)=SIN(TEMX)
  390 IF (ISKP(6)) 400,420,400
  400 AIN(61)=XK*O8+CONST(11)
      AIN(62)=YK*O9+CONST(12)
      WRITE (NTOUT,410) ATMSYM,IAT(6,IZ1),IC1CD,AIN(61),AIN(62),TEMP
  410 FORMAT (' Atom ',2A4,' (',I8,')  xp=',F8.3,' yp=',F8.3,
     1 ' r=',F7.2)
  420 IF (ISKP(7)) 430,570,430
  430 AIN(61)=(XK+TEMP)*O8+CONST(11)
      AIN(62)=YK*O9+CONST(12)
      CALL KPWPLT (AIN(61),3)
      DO 440 I=1,NST
      AIN(61)=(XK+TEMP*CTAB(I))*O8+CONST(11)
      AIN(62)=(YK+TEMP*STAB(I))*O9+CONST(12)
      CALL KPWPLT (AIN(61),2)
  440 CONTINUE
      IF (IPKFLG) 500,450,570
  450 IPKFLG=1
      IF (NSTPKT) 460,460,570
  460 IF (LCOMPS(ATMSYM,2,1, IBLANK,1)) 480,470,480
  470 AIN(61)=TEMP*0.9
      XORG=AIN(61)*.357143
      GO TO 490
  480 AIN(61)=TEMP*0.8
      XORG=AIN(61)*.857143
      CALL CNVTLO (ATMSYM,2,1)
  490 YORG=AIN(61)*.5
      CALL KPPCHR ((XK-XORG)*O8+CONST(11),(YK-YORG)*O9+CONST(12),
     1 ATMSYM,2,AIN(61)*O8)
      GO TO 570
  500 CALL KPWPLT (TBUF,16)
      GO TO 140
  510 IF (IPLTBF-5) 560,550,520
  520 IF (IPLTBF-7) 530,540,540
  530 INC=7+IPK(IPKPNT+6)
      GO TO 570
  540 INC=11
      GO TO 570
  550 INC=5
      GO TO 570
  560 INC=8
  570 IPKPNT=IPKPNT+INC
  580 IF (IPKPNT-IPKP) 220,590,590
  590 IF (IPKFLG) 610,610,600
  600 IPKFLG=-1
  610 IF (IC-NCDA) 960,960,620
  620 IC=IC-1
      IC2CD=ICD(IC)
      IZ2=IC2CD/100000
      IPKPNT=1
      GO TO 950
  630 IPLTBF=IPK(IPKPNT)
      IF (IPLTBF-2) 930,660,640
  640 IF (IPLTBF-5) 660,920,650
  650 IF (IPLTBF-7) 910,900,900
  660 INC=8
      IF (IZ1-IPK(IPKPNT+1)) 700,680,670
  670 IF (IZ1-IPK(IPKPNT+2)) 680,680,700
  680 IF (IZ2-IPK(IPKPNT+3)) 700,740,690
  690 IF (IZ2-IPK(IPKPNT+4)) 740,740,700
  700 IF (IZ1-IPK(IPKPNT+3)) 940,720,710
  710 IF (IZ1-IPK(IPKPNT+4)) 720,720,940
  720 IF (IZ2-IPK(IPKPNT+1)) 940,740,730
  730 IF (IZ2-IPK(IPKPNT+2)) 740,740,940
  740 IF (NPPOI) 810,810,750
  750 I=1
  760 IF (IC1CD-NPLST(I)) 780,770,780
  770 IF (IC2CD-NPLST(I+1)) 780,940,780
  780 IF (IC1CD-NPLST(I+1)) 800,790,800
  790 IF (IC2CD-NPLST(I)) 800,940,800
  800 I=I+2
      IF (I-NPPOI) 760,810,810
  810 DMAX=VQ(IPKPNT+6)
      TEMP=0.
      DO 830 I=1,3
      TEMP2=ABS(ATOMS(I,IC1)-ATOMS(I,IC))
      IF (TEMP2-DMAX) 820,820,940
  820 TEMP=TEMP+TEMP2*TEMP2
  830 CONTINUE
      IF (TEMP-DMAX*DMAX) 840,840,940
  840 IF (TEMP-VQ(IPKPNT+5)*VQ(IPKPNT+5)) 940,850,850
  850 CONTINUE
      T(3)=VQ(IPKPNT+7)
      X(2,2)=TEMPFK*T(3)
      NTYP=IPLTBF
      IF (ISKP(6)) 860,880,860
  860 TEMP=SQRT(TEMP)
      WRITE (NTOUT,870) IAT(5,IZ2),IAT(6,IZ2),IC2CD,TEMP
  870 FORMAT (' Bindung nach ',2A4,' (',I8,') d=',F8.4)
  880 IF (ISKP(7)) 890,940,890
  890 CALL KPVBU
      GO TO 940
  900 INC=11
      GO TO 940
  910 INC=7+IPK(IPKPNT+6)
      GO TO 940
  920 INC=5
      GO TO 940
  930 INC=4
  940 IPKPNT=IPKPNT+INC
  950 IF (IPKPNT-IPKP) 630,590,590
  960 IF (IPKFLG) 180,140,180
  970 CALL KPWPLT (TBUF,14)
      IPKPH=1
      GO TO 1170
  980 NTYP=IPK(IPKPH)
      IF (NTYP-5) 1000,1030,990
  990 IF (NTYP-7) 1070,1220,1220
 1000 IF (NTYP-2) 1010,1020,1020
 1010 INC=4
      GO TO 1160
 1020 INC=8
      GO TO 1160
 1030 INC=5
      IF (ISKP(7)) 1040,1160,1040
 1040 NC=1
      NTRY=28
      CDS(1)=VQ(IPKPH+1)
      CALL KPDEK
      TEMP=HOE/(HOE-X2(3))
      AIN(61)=(X2(1)+VQ(IPKPH+2))*TEMP*O8+CONST(11)
      AIN(62)=(X2(2)+VQ(IPKPH+3))*TEMP*O9+CONST(12)
      AIN(63)=VQ(IPKPH+4)*O9*TEMP
      IF (ISKP(26)) 1060,1050,1060
 1050 AIN(64)=4.
      AIN(65)=AT(5,IANR)
      CALL KPWPLT (AIN(61),11)
      GO TO 1160
 1060 CALL KPPCHR (AIN(61),AIN(62),AT(5,IANR),4,AIN(63))
      GO TO 1160
 1070 J=IPK(IPKPH+6)
      IF (ISKP(7)) 1080,1150,1080
 1080 NTRY=28
      DO 1100 I=1,2
      NC=I
      CDS(NC)=VQ(IPKPH+I)
      CALL KPDEK
      DO 1090 K=1,3
 1090 X(K,NC)=X2(K)
 1100 CONTINUE
      DO 1110 I=1,3
 1110 X2(I)=(X(I,1)+X(I,2))*.5
      TEMP=HOE/(HOE-X2(3))
      AIN(61)=(X2(1)+VQ(IPKPH+3))*TEMP*O8+CONST(11)
      AIN(62)=(X2(2)+VQ(IPKPH+4))*TEMP*O9+CONST(12)
      AIN(63)=VQ(IPKPH+5)*O9*TEMP
      IAIN(64)=4*J
      IF (ISKP(26)) 1140,1120,1140
 1120 JM=MAX0(J,8)
      DO 1130 I=1,JM
 1130 AIN(I+64)=VQ(IPKPH+I+6)
      AIN(64)=FLOAT(IAIN(64))
      CALL KPWPLT (AIN(61),11)
      GO TO 1150
 1140 CALL KPPCHR (AIN(61),AIN(62),IPK(IPKPH+7),IAIN(64),AIN(63))
 1150 INC=7+J
 1160 IPKPH=IPKPH+INC
 1170 IF (IPKPH-IPKP) 980,1180,1180
 1180 IF (ISKP(3)) 1190,9990,1190
 1190 DO 1200 J=1,10
 1200 AIN(J)=0.
      AIN(3)=CONST(8)
      AIN(5)=CONST(8)
      AIN(6)=CONST(9)
      AIN(8)=CONST(9)
      I=3
      DO 1210 J=1,9,2
      CALL KPWPLT (AIN(J),I)
      I=2
 1210 CONTINUE
      GO TO 9990
 1220 INC=11
      IF (NTYP-8) 1230,1160,1160
 1230 IF (ISKP(7)) 1240,1160,1240
 1240 DO 1250 I=1,10
 1250 IAIN(I)=IPK(IPKPH+I)
      CALL KPPPFL
      IF (IERR) 9990,1160,9990
 1260 NPPOI=0
      CALL FLES (AIN,ISKP(31),1HE,2H?$)
      GO TO 9993
 1270 DO 1280 I=1,72
 1280 IAIN(I)=0
      CALL FLES (IAIN,ISKP(31),4H72IE,11Hc1,c2,...?$)
      J=ISKP(31)
      I=0
      GO TO 1390
 1290 IF (NPPOI-NPDIM) 1320,1300,1300
 1300 CALL FLES (AIN,AIN,1HK,AIN)
      WRITE (NTOUT,1310)
 1310 FORMAT (' KPEXPU1250 - Tabelle NPLST voll.')
      GO TO 9993
 1320 NPPOI=NPPOI+1
      K=IAIN(I)
      IF (K) 1400,1380,1330
 1330 IF (NTYP-4) 1360,1340,1360
 1340 IF (K-NCDDM) 1350,1350,1400
 1350 K=ICD(K)
 1360 IF (K-NATDM) 1370,1370,1380
 1370 K=K*100000+55501
 1380 NPLST(NPPOI)=K
 1390 I=I+1
      IF (I-J) 1290,1290,9993
 1400 ISKP(10)=71400
      IERR=16
      NPPOI=NPPOI-1
      GO TO 9993
 9990 IF (ISKP(7)) 9991,9993,9991
 9991 CALL KPWPLT (TBUF,0)
      IF (ISKP(25)) 9992,9993,9992
 9992 CALL KPWPLT (TBUF,14)
 9993 NTYP=NTYPS
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPFKTR
                          SUBROUTINE KPFKTR
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      GO TO (10, 10, 220, 250, 260, 190, 200), NTYP
   10 K8=0
      NTRY=44
      NC=1
   20 IF (NCD-K9) 50,50,30
   30 K9=K9+1
      IC=K9
      CALL KPDEK
      DO 40 I=1,3
   40 ATOMS(I,K9)=X2(I)
      GO TO 20
   50 XMIN=1.E6
      XMAX=-1.E6
      YMIN=1.E6
      YMAX=-1.E6
      IF (NCD-NCDA) 60,60,70
   60 ISKP(10)=290060
      IERR=18
      GO TO 180
   70 DO 80 I=NCDA,NCD
      TEMP=HOE/(HOE-ATOMS(3,I))
      TA=ATOMS(1,I)*TEMP
      XMIN=AMIN1(XMIN,TA)
      XMAX=AMAX1(XMAX,TA)
      TA=ATOMS(2,I)*TEMP
      YMIN=AMIN1(YMIN,TA)
      YMAX=AMAX1(YMAX,TA)
   80 CONTINUE
      IF (NTYP-1) 999,90,140
   90 TA=CONST(8)-2.*CONST(10)
      TEMP=XMAX-XMIN
      IF (TEMP) 100,100,110
  100 TEMP=0.00001
  110 T1=TA/TEMP
      TA=CONST(9)-2.*CONST(10)
      TEMP=YMAX-YMIN
      IF (TEMP) 120,120,130
  120 TEMP=0.00001
  130 T2=TA/TEMP
      TEMP=AMIN1(T1,T2)
      O8=TEMP
      O9=TEMP
      GO TO 170
  140 AIN(1)=1.
      IF (ISKP(14)) 160,150,160
  150 CALL FLES (AIN,ISKP(31),2HFE,8HFaktor?$)
  160 O8=O8*AIN(1)
      O9=O9*AIN(1)
  170 CONST(15)=.2924791/O9
      CONST(11)=(-(XMIN+XMAX)*O8+CONST(8))*.5
      CONST(12)=(-(YMIN+YMAX)*O9+CONST(9))*.5
  180 IF (NTYP-1) 999,280,999
  190 AIN(1)=.5
      GO TO 210
  200 AIN(1)=2.
  210 CONST(8)=CONST(8)*AIN(1)
      O8=O8*AIN(1)
      O9=O9*AIN(1)
      CONST(11)=CONST(11)*AIN(1)
      GO TO 240
  220 IF (ISKP(14)) 240,230,240
  230 CALL FLES (CONST(8),ISKP(31),3H3FE,10Hx,y,Rand?$)
  240 AIN(1)=0.
      AIN(2)=CONST(8)
      AIN(3)=0.
      AIN(4)=CONST(9)
      CALL KPWPLT (AIN,12)
      IF (NTYP-6) 999,280,280
  250 CALL FLES (CONST(11),ISKP(31),3H2FE,5Hx,y?$)
      GO TO 999
  260 TEMP=HOE*O8
      WRITE (NTOUT,270) (CONST(I),I=8,12), O8, TEMP, CONST(15)
  270 FORMAT ('0Zeichenfeld:',F7.2,' cm mal',F7.2,' cm mit',F6.2,' cm Ra
     1nd',/,' Ursprung:',F6.2,1H,,F6.2,'; Skalenfaktor:',F7.3,' cm/A',/,
     2 ' Betrachterabstand:',E10.3,' cm; Schrifthoehe:',F6.2,' A')
      GO TO 280
  280 IF (ISKP(14)) 999,290,999
  290 CALL FLES (AIN,ISKP(31),1HE,2H?$)
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPFNIN
                           SUBROUTINE KPFNIN
      DIMENSION ATPAR(8),ATNMPR(3),NMATPR(3),RADBF(3),IRADBF(3)
      DIMENSION IAIN(72)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ IOUNIT(9)
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (ATNMPR(1),NMATPR(1)),(RADBF(1),IRADBF(1))
      EQUIVALENCE (AIN(1),IAIN(1)),(NTOUT,IOUNIT(2))
      DATA ATPAR/4HUNDE,4HFINI,3*0.,.3,4HUNDE,4HFINI/
      DATA ATNMPR/4HUNDE,4HFINI,0./,BLANK/4H    /
      DATA RADBF(1)/.3/,IRADBF(2)/3/,IRADBF(3)/0/
      GO TO (10,20,20,50,100,110,150,220,270,310,320,360,400,520,
     1 620,620),NTYP
   10 CALL FLES (TITEL,ISKP(31),4H18AE,7HTitel?$)
      GO TO 999
   20 ATPAR(8)=BLANK
      CALL FLES (ATPAR(3),ISKP(31),5H4FAAE,
     1 21Hx,y,z,r,Name,diffr.?$)
      ATPAR(1)=ATPAR(7)
      ATPAR(2)=ATPAR(8)
      IF (NTYP-2) 60,60,30
   30 DO 40 I=3,5
   40 ATPAR(I)=ATPAR(I)/GRID(I-2)
      GO TO 60
   50 ATPAR(2)=BLANK
      CALL FLES (ATPAR,ISKP(31),5HAA4FE,
     1 21HName,diffr.,x,y,z,r?$)
      ATPAR(7)=ATPAR(1)
      ATPAR(8)=ATPAR(2)
   60 IF (NAT-NATDM) 80,70,70
   70 ISKP(10)=580070
      IERR=2
      GO TO 999
   80 NAT=NAT+1
      DO 90 I=1,6
   90 AT(I,NAT)=ATPAR(I+2)
      GO TO 999
  100 CALL FLES (GRID,ISKP(31),3H3FE,10Hna,nb,nc?$)
      GO TO 999
  110 NMATPR(3)=NMATPR(3)+1
      CALL FLES (ATNMPR,ISKP(31),4HAAIE,19HName,Untersch.,nr?$)
      J=NMATPR(3)
      IF (J) 130,130,120
  120 IF (J-NATDM) 140,140,130
  130 ISKP(10)=580130
      GO TO 990
  140 AT(5,J)=ATNMPR(1)
      AT(6,J)=ATNMPR(2)
      GO TO 999
  150 IRADBF(3)=0
      CALL FLES (RADBF,ISKP(31),4HF2IE,15Hr,<von<,bis>>?$)
      IF (IRADBF(3)) 160,160,170
  160 IRADBF(3)=IRADBF(2)
  170 I=IRADBF(2)-1
      IF (I) 190,180,180
  180 IF (IRADBF(3)-NATDM) 210,210,190
  190 ISKP(10)=580190
      GO TO 990
  200 I=I+1
      AT(4,I)=RADBF(1)
  210 IF (I-IRADBF(3)) 200,999,999
  220 AIN(1)=.3
      AIN(2)=BLANK
      IAIN(3)=3
      IAIN(4)=NAT
      CALL FLES (AIN,ISKP(31),5HFA2IE,
     1 19Hr,symb.<,from,to>?$)
      CALL CNVTUP (AIN(2),1,4)
      I=IAIN(3)-1
      IF (I) 240,230,230
  230 IF (IAIN(4)-NATDM) 260,260,240
  240 ISKP(10)=580240
      GO TO 990
  250 I=I+1
      AIN(5)=AT(5,I)
      CALL CNVTUP (AIN(5),1,4)
      IF (IAIN(2) .EQ. IAIN(5)) AT(4,I)=AIN(1)
  260 IF (I-IAIN(4)) 250,999,999
  270 CALL FLES (IAIN,ISKP(31),2HIE,5HNr.?$)
      IF (IAIN(1)) 290,300,280
  280 IF (IAIN(1)-NATDM) 300,300,290
  290 ISKP(10)=580290
      GO TO 990
  300 NAT=IAIN(1)
      K8=0
      K9=0
      GO TO 999
  310 CALL FLES (FKGL,ISKP(31),2HFE,
     1 8Hfactor?$)
      GO TO 999
  320 CALL FLES (AIN,ISKP(31),4H12FE,28Ht1,s11,s12,s13, t2,...,s33?$)
      IF (NSYM-NSYMDM) 330,350,350
  330 NSYM=NSYM+1
      DO 340 I=1,12
  340 SYM(I,NSYM)=AIN(I)
      GO TO 999
  350 ISKP(10)=580350
      IERR=3
      GO TO 999
  360 CALL FLES (IAIN,ISKP(31),2HIE,4HNr?$)
      IF (IAIN(1)) 380,390,370
  370 IF (IAIN(1)-48) 390,390,380
  380 ISKP(10)=580380
      GO TO 990
  390 NSYM=IAIN(1)
      GO TO 999
  400 IAIN(2)=0
      CALL FLES (IAIN,ISKP(31),3H2IE,
     1 11Hfrom<,to>?$)
      IF (IAIN(2)) 440,440,410
  410 IF (IAIN(2)-NSYM) 430,430,420
  420 IAIN(2)=NSYM
  430 IF (IAIN(1)-IAIN(2)) 450,450,470
  440 IAIN(2)=IAIN(1)
  450 IF (IAIN(1)) 470,470,460
  460 IF (IAIN(1)-NSYM) 500,500,470
  470 ISKP(10)=580470
      GO TO 990
  480 DO 490 J=1,12
  490 SYM(J,IAIN(1))=SYM(J,IAIN(2))
      IAIN(1)=IAIN(1)+1
  500 IAIN(2)=IAIN(2)+1
      IF (IAIN(2)-NSYM) 480,480,510
  510 NSYM=IAIN(1)-1
      GO TO 999
  520 IAIN(2)=0
      CALL FLES (AIN,ISKP(31),3H2IE,
     1 11Hfrom<,to>?$)
      IZ1=IAIN(1)
      IZ2=IAIN(2)
      IF (IZ2) 530,530,540
  530 IZ2=IZ1
  540 IF (IZ1) 570,570,550
  550 IF (IZ1-NAT) 560,610,999
  560 IF (IZ1-IZ2) 580,580,570
  570 ISKP(10)=580570
      GO TO 990
  580 IZ2=IZ2+1
      IF (IZ2-NAT) 590,590,610
  590 DO 600 I=1,6
  600 AT(I,IZ1)=AT(I,IZ2)
      IZ1=IZ1+1
      GO TO 580
  610 NAT=IZ1-1
      GO TO 999
  620 CALL FLES (AIN(2),ISKP(31),4H32ZE,18Hhxch1,hxch2, ...?$)
      J=ISKP(31)
      AIN(1)=J
      IF (J) 650,650,630
  630 DO 640 I=1,J
      CALL COPYCH (AIN,I*4+4,1, AIN,I+4)
  640 CONTINUE
  650 J=NTYP+5
      CALL KPWPLT (AIN,J)
      GO TO 999
  990 IERR=16
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPGE01
                          SUBROUTINE KPGE01
      INTEGER CDS,KONST(40)
      DIMENSION PT(3),PF(3),A(3,3),VA(3),PU(3),IAIN(72)
      DIMENSION SAVK(3,4),INBFR(3)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1)),(CONST(1),KONST(1))
      EQUIVALENCE (PTRIKL(1),PT(1)),(PFREI(1),PF(1))
      EQUIVALENCE (AIN(57),A(1,1)),(AIN(56),G),(AIN(55),TEMP)
      EQUIVALENCE (X(1,1),PU(1)),(X(1,2),VA(1)),(CONST(3),BOG)
      EQUIVALENCE (AIN(1),IVON),(AIN(2),IBIS),(AIN(3),IACHSE)
      DATA KDR/4HR   /
      NATSV=0
      NTYPS=NTYP
      GO TO (10,60,110,140,170,420,580,700,790,800,920,1020,1020,1110,
     1     20,70,1250,300,1280,1280,280), NTYP
   10 CALL FLES (PF,ISKP(31),3H3FE,7Hx,y,z?$)
   20 DO 30 I=1,3
   30 PT(I)=TRAINV(I,1)*PF(1)+TRAINV(I,2)*PF(2)+TRAINV(I,3)*PF(3)+UR(I)
      IF (NTYPS-20) 9999,40,9999
   40 DO 50 I=1,3
   50 UR(I)=PT(I)
      GO TO 9999
   60 CALL FLES (PT,ISKP(31),3H3FE,7Hx,y,z?$)
   70 DO 80 I=1,3
   80 X1(I)=PT(I)-UR(I)
      DO 90 I=1,3
   90 PF(I)=TRA(I,1)*X1(1)+TRA(I,2)*X1(2)+TRA(I,3)*X1(3)
      IF (NTYPS-20) 9999,100,9999
  100 PF(3)=AIN(7)
      GO TO 20
  110 WRITE (NTOUT,120) PT,PF
  120 FORMAT (6F10.5)
  130 CALL FLES (AIN,ISKP(31),1HE,2H?$)
      GO TO 9999
  140 CALL FLES (CDS,ISKP(31),2HIE,6HCode?$)
      NC=1
      NTRY=28
      CALL KPDEK
      IF (IERR) 9999,150,9999
  150 DO 160 I=1,3
      PT(I)=PU(I)
  160 PF(I)=X2(I)
      KONST(27)=CDS(1)
      KONST(28)=CDS(1)
      GO TO 9999
  170 IF (ISKP(14)) 190,180,190
  180 AIN(2)=CONST(6)
      CALL FLES (AIN,ISKP(31),3HIFE,12HAchse,Grad?$)
  190 I=IAIN(1)
      G=AIN(2)
  200 IF (I) 220,220,210
  210 IF (I-3) 230,230,220
  220 ISKP(10)=90220
      IERR=7
      IF (NTYPS-18) 9999,380,9999
  230 DO 240 J=1,3
      DO 240 K=1,3
  240 S(J,K)=0.
      S(I,I)=1.
      J=ID2(I)
      K=ID2(J)
      TEMP=COS(G*BOG)
      S(J,J)=TEMP
      S(K,K)=TEMP
      TEMP=SIN(G*BOG)
      S(K,J)=TEMP
      S(J,K)=-TEMP
      IF (NTYP-6) 250,430,9999
  250 DO 260 I=1,3
  260 PU(I)=S(I,1)*PF(1)+S(I,2)*PF(2)+S(I,3)*PF(3)
      DO 270 I=1,3
  270 PF(I)=PU(I)
      GO TO 20
  280 IERRSV=0
      INBFR(3)=KONST(6)
      CALL FLES (INBFR,ISKP(31),4H2IFE,12Hp1,p2,Grad?$)
      KONST(6)=INBFR(3)
      DO 290 I=1,3
      IAIN(I+7)=INBFR(I)
      AIN(I+12)=UR(I)
      AIN(I+15)=UR(I)+TRAINV(I,1)
      AIN(I+18)=UR(I)+TRAINV(I,2)
  290 CONTINUE
      AIN(10)=-AIN(10)
      IAIN(6)=0
      IAIN(7)=0
      IAIN(11)=0
      GO TO 310
  300 IERRSV=0
      IAIN(11)=0
      AIN(10)=CONST(6)
      CALL FLES (AIN(6),ISKP(31),5H4IFAE,25Hvon,bis,p1,p2,Grad (,R)?$)
  310 DO 330 I=1,3
      DO 320 J=1,3
  320 SAVK(I,J)=DREH(I,J)
  330 SAVK(I,4)=UR(I)
      DO 370 I=8,9
      J=IAIN(I)
      IF (J) 340,340,370
  340 J=-J
      IF (J-NCDDM) 360,360,350
  350 ISKP(10)=90350
      GO TO 1170
  360 IAIN(I)=ICD(J)
  370 CONTINUE
      CDS(1)=IAIN(8)
      CDS(2)=IAIN(8)
      CDS(3)=IAIN(9)
      CDS(4)=0
      IZ1=IAIN(6)
      IZ2=IAIN(7)
      IF (IAIN(11) .EQ. KDR) NATSV=NAT
      I=1
      G=AIN(10)
      ISKP14=ISKP(14)
      ISKP(14)=1
      NTYP=1
      CALL KPK
      ISKP(14)=ISKP14
      NTYP=6
      IF (IERR) 380,200,380
  380 IERRSV=IERR
  390 DO 410 I=1,3
      DO 400 J=1,3
  400 DREH(I,J)=SAVK(I,J)
  410 UR(I)=SAVK(I,4)
      NTYP=3
      CALL KPK
      IERR=IERRSV
      GO TO 9999
  420 IAIN(5)=0
      AIN(4)=CONST(6)
      CALL FLES (AIN,ISKP(31),5H3IFAE,25Hvon,bis,Achse,Grad (,R)?$)
      IF (IAIN(5) .EQ. KDR) NATSV=NAT
      IZ1=IAIN(1)
      IZ2=IAIN(2)
      I=IAIN(3)
      G=AIN(4)
      GO TO 200
  430 DO 440 I=1,3
      DO 440 J=1,3
  440 A(I,J)=S(I,1)*TRA(1,J)+S(I,2)*TRA(2,J)+S(I,3)*TRA(3,J)
      DO 450 I=1,3
      DO 450 J=1,3
  450 S(I,J)=TRAINV(I,1)*A(1,J)+TRAINV(I,2)*A(2,J)+TRAINV(I,3)*A(3,J)
      IF (NTYPS-21) 520,460,520
  460 K=12
      L=1
  470 DO 480 J=1,3
      K=K+1
  480 AIN(J+21)=AIN(K)-UR(J)
      DO 490 J=1,3
  490 X(J,L)=S(J,1)*AIN(22)+S(J,2)*AIN(23)+S(J,3)*AIN(24)+UR(J)
      L=L+2
      IF (L-5) 470,470,500
  500 DO 510 J=1,3
      X(J,2)=X(J,1)
      X(J,4)=X(J,1)
  510 CONTINUE
      NTYP=12
      CALL KPK
      IF (IERR) 380,9999,380
  520 IF (NATSV .GT. 0) NAT=IZ1-1
      DO 560 I=IZ1,IZ2
      IF (NAT-NATDM) 530,570,570
  530 NAT=NAT+1
      DO 540 J=1,3
  540 PU(J)=AT(J,I)-UR(J)
      DO 550 J=1,3
  550 AT(J,NAT)=S(J,1)*PU(1)+S(J,2)*PU(2)+S(J,3)*PU(3)+UR(J)
      AT(4,NAT)=AT(4,I)
      AT(5,NAT)=AT(5,I)
      AT(6,NAT)=AT(6,I)
  560 CONTINUE
      GO TO 670
  570 ISKP(10)=90570
      IERR=2
      IF (NTYPS-18) 9999,380,9999
  580 IAIN(5)=0
      CALL FLES (AIN,ISKP(31),4H4IAE,20Hvon,bis,p1,p2 (,R)?$)
      IF (ISKP(31)-4) 590,600,600
  590 ISKP(10)=90590
      GO TO 1170
  600 IZ1=IAIN(1)
      IZ2=IAIN(2)
      CDS(1)=IAIN(3)
      CDS(2)=IAIN(4)
      NTRY=24
      DO 610 NC=1,2
      CALL KPDEK
      IF (IERR) 9999,610,9999
  610 CONTINUE
      DO 620 I=1,3
  620 PU(I)=VA(I)-PU(I)
      IF (IAIN(5) .NE. KDR) GO TO 630
      NATSV=NAT
      NAT=IZ1-1
  630 DO 660 I=IZ1,IZ2
      IF (NAT-NATDM) 640,570,570
  640 NAT=NAT+1
      DO 650 J=1,3
  650 AT(J,NAT)=AT(J,I)+PU(J)
      AT(4,NAT)=AT(4,I)
      AT(5,NAT)=AT(5,I)
      AT(6,NAT)=AT(6,I)
  660 CONTINUE
  670 IF (NATSV) 690,690,680
  680 NAT=NATSV
  690 IF (NTYPS-18) 9999,380,9999
  700 DO 710 I=1,72
  710 IAIN(I)=100
      CALL FLES (AIN,ISKP(31),4H72IE,25HCode,Gewicht(100*I),...?$)
      NC=1
      NTRY=24
      DO 720 I=1,3
  720 X1(I)=0.
      SUM=0.
      J=((ISKP(31)+1)/2)*2
      DO 750 I=2,J,2
      CDS(1)=IAIN(I-1)
      H=FLOAT(IAIN(I))
      CALL KPDEK
      IF (IERR) 9999,730,9999
  730 SUM=SUM+H
      DO 740 K=1,3
  740 X1(K)=X1(K)+H*X(K,1)
  750 CONTINUE
      IF (SUM) 760,760,770
  760 ISKP(10)=90760
      GO TO 1170
  770 DO 780 K=1,3
  780 PTRIKL(K)=X1(K)/SUM
      GO TO 70
  790 TEMP=HOE/(HOE-PFREI(3))
      T(1)=PFREI(1)*TEMP*O8+CONST(11)
      T(2)=PFREI(2)*TEMP*O9+CONST(12)
      CALL KPWPLT (T,7)
      GO TO 130
  800 IACHSE=3
      IAIN(4)=0
      CALL FLES (AIN,ISKP(31),4H3IAE,20Hvon,bis,Achse (,R)?$)
      IF (IVON) 850,850,810
  810 IF (IBIS-NATDM) 820,820,850
  820 IF (IVON-IBIS) 830,830,850
  830 IF (IACHSE) 850,850,840
  840 IF (IACHSE-3) 860,860,850
  850 ISKP(10)=90850
      GO TO 1170
  860 NC=1
      IF (IAIN(4) .NE. KDR) GO TO 870
      NATSV=NAT
      NAT=IVON-1
  870 NTRY=4
      DO 910 IANR=IVON,IBIS
      IF (NAT-NATDM) 880,570,570
  880 NAT=NAT+1
      DO 890 I=1,3
  890 X(I,1)=AT(I,IANR)
      CALL KPDEK
      X2(IACHSE)=-X2(IACHSE)
      DO 900 I=1,3
      AT(I,NAT)=TRAINV(I,1)*X2(1)+TRAINV(I,2)*X2(2)+TRAINV(I,3)*X2(3)
     1 + UR(I)
  900 AT(I+3,NAT)=AT(I+3,IANR)
  910 CONTINUE
      GO TO 9999
  920 IBIS=0
      IAIN(4)=0
      CALL FLES (AIN,ISKP(31),4H3IAE,20Hvon,bis,czent (,R)?$)
      CDS(1)=IAIN(3)
      NC=1
      NTRY=24
      CALL KPDEK
      IF (IERR) 9999,930,9999
  930 I=IVON-1
      IF (IAIN(4) .NE. KDR) GO TO 1010
      NATSV=NAT
      NAT=I
      GO TO 1010
  940 I=I+1
      IF (I) 960,960,950
  950 IF (I-NATDM) 970,970,960
  960 ISKP(10)=90960
      IERR=4
      GO TO 9999
  970 IF (NAT-NATDM) 990,980,980
  980 ISKP(10)=90980
      IERR=2
      GO TO 9999
  990 NAT=NAT+1
      DO 1000 J=1,3
      AT(J,NAT)=2.*X(J,1)-AT(J,I)
      AT(J+3,NAT)=AT(J+3,I)
 1000 CONTINUE
 1010 IF (I-IBIS) 940,9999,9999
 1020 CALL FLES (AIN,ISKP(31),3H2IE,7Hn1,n2?$)
      IF (IVON) 1060,1060,1030
 1030 IF (IVON-NATDM) 1040,1040,1060
 1040 IF (IBIS) 1060,1060,1050
 1050 IF (IBIS-NATDM) 1070,1070,1060
 1060 ISKP(10)=91060
      IERR=4
      GO TO 9999
 1070 J=4
      IF (NTYP-13) 1090,1080,9999
 1080 J=6
 1090 DO 1100 I=1,J
      H=AT(I,IVON)
      AT(I,IVON)=AT(I,IBIS)
 1100 AT(I,IBIS)=H
      GO TO 9999
 1110 CALL FLES (AIN,ISKP(31),3H3IE,15Hvon<,bis>,vor?$)
      IF (ISKP(31)-2) 1160,1120,1130
 1120 IAIN(3)=IAIN(2)
      IAIN(2)=IAIN(1)
 1130 IF (IAIN(1) .LE. 0) GO TO 1160
      IF (IAIN(1) .GT. IAIN(2)) GO TO 1160
      IF (IAIN(3) .GT. IAIN(2)) GO TO 1140
      IAIN(4)=IAIN(3)
      IAIN(3)=IAIN(2)+1
      IAIN(2)=IAIN(1)-1
      IAIN(1)=IAIN(4)
      GO TO 1130
 1140 IAIN(3)=IAIN(3)-1
      IF (IAIN(2)-IAIN(3)) 1150,9999,1160
 1150 IF (IAIN(3) .LE. NATDM+1) GO TO 1180
 1160 ISKP(10)=91160
 1170 IERR=16
      GO TO 9999
 1180 IAIN(7)=IAIN(1)-1
      IAIN(10)=IAIN(3)-IAIN(7)
      IAIN(5)=IAIN(2)-IAIN(7)
      IAIN(4)=IAIN(3)-IAIN(2)
      IAIN(6)=0
 1190 IAIN(7)=IAIN(7)+1
      IAIN(8)=IAIN(7)
      DO 1200 I=1,6
 1200 AIN(I+10)=AT(I,IAIN(7))
      GO TO 1230
 1210 DO 1220 I=1,6
 1220 AT(I,IAIN(8))=AT(I,IAIN(9))
      IAIN(8)=IAIN(9)
 1230 IAIN(6)=IAIN(6)+1
      IAIN(9)=IAIN(8)+IAIN(5)
      IF (IAIN(9) .GT. IAIN(3)) IAIN(9)=IAIN(8)-IAIN(4)
      IF (IAIN(9) .NE. IAIN(7)) GO TO 1210
      DO 1240 I=1,6
 1240 AT(I,IAIN(8))=AIN(I+10)
      IF (IAIN(6) .LT. IAIN(10)) GO TO 1190
      GO TO 9999
 1250 DO 1260 I=1,3
 1260 AIN(I)=0.
      CALL FLES (AIN,ISKP(31),3H3FE,7Hx,y,z?$)
      DO 1270 I=1,3
 1270 PF(I)=PF(I)+AIN(I)
      GO TO 20
 1280 IAIN(1)=1
      IAIN(2)=NAT
      CALL FLES (IAIN,ISKP(31),3H2IE,13Hnrmin,nrmax?$)
      IF (NCD-NCDA) 1290,1300,1300
 1290 ISKP(10)=91290
      IERR=12
      GO TO 9999
 1300 K9=0
      DO 1310 J=3,6
 1310 AIN(J)=0.
      AIN(7)=-1000.
      NC=1
      DO 1390 IC=NCDA,NCD
      NTRY=32
      CALL KPDEK
      IF (IERR) 9999,1320,9999
 1320 IF (IANR-IVON) 1390,1330,1330
 1330 IF (IANR-IBIS) 1340,1340,1390
 1340 NTRY=8
      IF (NTYPS-20) 1360,1350,1360
 1350 NTRY=12
 1360 CALL KPDEK
      IF (IERR) 9999,1370,9999
 1370 TEMP=AT(4,IANR)
      DO 1380 J=3,5
 1380 AIN(J)=AIN(J)+X(J-2,1)*TEMP
      AIN(6)=AIN(6)+TEMP
      AIN(7)=AMAX1(AIN(7),X2(3))
 1390 CONTINUE
      IF (AIN(6)) 1410,1400,1410
 1400 ISKP(10)=91400
      IERR=16
      GO TO 9999
 1410 DO 1420 J=1,3
 1420 PTRIKL(J)=AIN(J+2)/AIN(6)
      GO TO 70
 9999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--KPGE02
                          SUBROUTINE KPGE02
      INTEGER CDS
      DIMENSION IAIN(72)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1))
      DATA BLANK,UND1,UND2/4H    ,4HUNDE,4HFINI/
      GO TO (10,70,999,130,190,180,350,999,430,480,550,550), NTYP
   10 AIN(1)=0.3
      AIN(3)=BLANK
      AIN(4)=BLANK
      IAIN(2)=NAT+1
      CALL FLES (AIN,ISKP(31),5HFIAAE,
     1 17Hr,Nr,name,diff.?$)
      I=IAIN(2)
      IF (I .LE. 0) GO TO 30
   20 IF (I .LE. NATDM) GO TO 40
   30 ISKP(10)=100030
      IERR=16
      GO TO 999
   40 DO 50 J=1,3
   50 AT(J,I)=PTRIKL(J)
      AT(4,I)=AIN(1)
      IF (ISKP(33) .LE. 0) GO TO 60
      AT(5,I)=AIN(3)
      AT(6,I)=AIN(4)
   60 IF (I .GT. NAT) NAT=I
      GO TO 999
   70 AIN(1)=.3
      AIN(3)=UND1
      AIN(4)=UND2
      CALL FLES (AIN,ISKP(31),5HFIAAE,
     1 17Hr,Nr,name,diff.?$)
      I=IAIN(2)
      IF (I .LE. 0) GO TO 30
      IF (I .GT. NAT) GO TO 20
      IF (NAT .LT. NATDM) GO TO 90
   80 ISKP(10)=100080
      IERR=2
      GO TO 999
   90 DO 110 J=I,NAT
      K=NAT-J+I
      DO 100 L=1,6
  100 AT(L,K+1)=AT(L,K)
  110 CONTINUE
      NAT=NAT+1
      DO 120 L=1,3
  120 AT(L,I)=PTRIKL(L)
      AT(4,I)=AIN(1)
      AT(5,I)=AIN(3)
      AT(6,I)=AIN(4)
      IF (ISKP(33)+ISKP(34) .EQ. 1) AT(6,I)=BLANK
      GO TO 999
  130 CALL FLES (CDS,ISKP(31),3H2IE,7Hc1,c2?$)
      NTRY=26
      NC=1
      CALL KPDEK
      IF (IERR .NE. 0) GO TO 999
      AIN(1)=AT(5,IANR)
      AIN(2)=AT(6,IANR)
      IAIN(3)=CDS(1)
      DO 140 I=1,3
  140 X2(I)=X1(I)
      NC=2
      CALL KPDEK
      IF (IERR .NE. 0) GO TO 999
      AIN(4)=AT(5,IANR)
      AIN(5)=AT(6,IANR)
      IAIN(6)=CDS(2)
      TEMP=0.
      DO 150 I=1,3
      AIN(10)=X1(I)-X2(I)
  150 TEMP=TEMP+AIN(10)*AIN(10)
      TEMP=SQRT(TEMP)
      WRITE (NTOUT,160) (IAIN(I),I=1,6),TEMP
  160 FORMAT (' D: ',2A4,' (',I8,') ',2A4,' (',I8,') ',F10.5)
  170 CONST(5)=TEMP
      GO TO 999
  180 CALL FLES (CDS,ISKP(31),3H4IE,18Hc1a,c2a, c1b,c2b?$)
      J4=4
      GO TO 200
  190 CALL FLES (CDS,ISKP(31),3H3IE,10Hc1,cz,c2?$)
      J4=3
  200 NTRY=26
      DO 220 NC=1,J4
      CALL KPDEK
      IF (IERR .NE. 0) GO TO 999
      I=3*NC-2
      AIN(I)=AT(5,IANR)
      AIN(I+1)=AT(6,IANR)
      IAIN(I+2)=CDS(NC)
      DO 210 I=1,3
  210 X(I,NC)=X1(I)
  220 CONTINUE
      IF (J4-4) 250,230,230
  230 DO 240 I=1,3
  240 X(I,3)=X(I,4)+X(I,2)-X(I,3)
  250 T1=0.
      T2=0.
      T3=0.
      DO 260 I=1,3
      AIN(20)=X(I,1)-X(I,2)
      T1=T1+AIN(20)*AIN(20)
      TEMP=X(I,3)-X(I,2)
      T2=T2+TEMP*TEMP
  260 T3=T3+AIN(20)*TEMP
      T1=T1*T2
      IF (T1 .GT. 0.) GO TO 270
      ISKP(10)=100260
      IERR=6
      GO TO 999
  270 TEMP=T3/SQRT(T1)
      IF (TEMP .GT. -1.) GO TO 280
      TEMP=180.
      GO TO 300
  280 IF (TEMP .LT. 1.) GO TO 290
      TEMP=0.
      GO TO 300
  290 CONTINUE
      TEMP=ACOS(TEMP)/CONST(3)
  300 IF (NTYP .EQ. 10) GO TO 510
      IF (NTYP .EQ. 7) GO TO 410
      IF (NTYP .EQ. 6) GO TO 330
      WRITE (NTOUT,310) (IAIN(I),I=1,9),TEMP
  310 FORMAT (
     1 ' A: ',3(2A4,' (',I8,') '),F7.2)
  320 CONST(6)=TEMP
      GO TO 999
  330 WRITE (NTOUT,340) (IAIN(I),I=1,12),TEMP
  340 FORMAT (
     1 ' Winkel: ',2(2A4,' (',I8,') '),/,
     2 ' ',8X,2(2A4,' (',I8,') '),F7.2)
      GO TO 320
  350 CALL FLES (CDS,ISKP(31),3H6IE,20Hp1,p2,p3, p4,p5,p6?$)
      IF (ISKP(31) .GE. 6) GO TO 360
      ISKP(10)=100350
      GO TO 990
  360 NTRY=26
      DO 380 NC=1,6
      CALL KPDEK
      IF (IERR .NE. 0) GO TO 999
      I=3*NC-2
      AIN(I)=AT(5,IANR)
      AIN(I+1)=AT(6,IANR)
      IAIN(I+2)=CDS(NC)
      DO 370 J=1,3
  370 X(J,NC)=X1(J)
  380 CONTINUE
      DO 390 I=1,3
      X(I,6)=X(I,5)-X(I,6)
      X(I,5)=X(I,5)-X(I,4)
      X1(I)= X(I,2)-X(I,1)
      X2(I)= X(I,2)-X(I,3)
  390 CONTINUE
      DO 400 I=1,3
      J=ID2(I)
      K=ID2(J)
      X(I,1)=X1(J)*X2(K)-X1(K)*X2(J)
      X(I,2)=0.
      X(I,3)=X(J,5)*X(K,6)-X(K,5)*X(J,6)
  400 CONTINUE
      GO TO 250
  410 WRITE (NTOUT,420) (IAIN(I),I=1,18),TEMP
  420 FORMAT (
     1 ' A: ',3(2A4,' (',I8,') '),/,
     2 '    ',3(2A4,' (',I8,') '),F7.2)
      GO TO 999
  430 K8=0
      NTRY=44
      NC=1
      IC=K9
      GO TO 460
  440 IC=IC+1
      CALL KPDEK
      DO 450 I=1,3
  450 ATOMS(I,IC)=X2(I)
  460 IF (NCD-IC) 470,470,440
  470 K9=NCD
      GO TO 999
  480 IF (ISKP(14) .NE. 0) GO TO 500
      CALL FLES (CDS,ISKP(31),3H4IE,13Hp1,p2,p3,p4?$)
      IF (ISKP(31)-4) 490,500,500
  490 ISKP(10)=100490
      GO TO 990
  500 CDS(6)=CDS(4)
      CDS(5)=CDS(3)
      CDS(4)=CDS(2)
      GO TO 360
  510 T2=TEMP
      IF (X(1,1)*X(1,6)+X(2,1)*X(2,6)+X(3,1)*X(3,6)) 520,530,530
  520 TEMP=-TEMP
      T2=360.+TEMP
  530 CONST(6)=T2
      WRITE (NTOUT,540) IAIN(1),IAIN(2),IAIN(4),IAIN(5),
     1                 IAIN(13),IAIN(14),IAIN(16),IAIN(17),TEMP,
     2                  IAIN(3),IAIN(6),IAIN(15),IAIN(18),T2
  540 FORMAT (' ',/,
     1 ' Torsion-  ',3(2A4,' - '),2A4,F10.2,/,
     2 ' angle     ',4('(',I8,') '),'(',F7.2,')')
      GO TO 999
  550 AIN(1)=1.
      AIN(2)=0.
      CALL FLES (AIN,ISKP(31),3H2FE,
     1 13Hfactor,add.?$)
      TEMP=CONST(NTYP-6)*AIN(1)+AIN(2)
      WRITE (NTOUT,560) TEMP
  560 FORMAT (' Result:',F10.5)
      IF (NTYP-11) 999,170,320
  990 IERR=16
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPGE03
                          SUBROUTINE KPGE03
      DIMENSION IAIN(72)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1))
      DATA KDR/4HR   /
      GO TO (10,150,130,360,450,450,300,570,560,660,830,860,860), NTYP
   10 CDS(4)=CONST(5)
      CALL FLES (CDS,ISKP(31),4H3IFE,20Hcpkt,p1,p2,Abstand?$)
      NTRY=28
      DO 40 NC=1,3
      CALL KPDEK
      IF (IERR) 9999,20,9999
   20 DO 30 J=1,3
   30 X(J,NC)=X2(J)
   40 CONTINUE
      DO 50 I=5,9
   50 AIN(I)=0.
      DO 60 I=1,3
      AIN(10)=X(I,1)-X(I,2)
      AIN(5)=AIN(5)+AIN(10)*AIN(10)
      AIN(10)=X(I,1)-X(I,3)
      AIN(6)=AIN(6)+AIN(10)*AIN(10)
      AIN(10)=X(I,3)-X(I,2)
      AIN(7)=AIN(7)+AIN(10)*AIN(10)
      X1(I)=AIN(10)
   60 CONTINUE
      IF (AIN(7)) 70,70,80
   70 ISKP(10)=250070
      IERR=6
      GO TO 9999
   80 AIN(9)=CDS(4)*CDS(4)
      AIN(8)=SQRT(AIN(7))
      AIN(10)=(AIN(7)+AIN(5)-AIN(6))/(2.*AIN(8))
      AIN(11)=AIN(9)-AIN(5)+AIN(10)*AIN(10)
      IF (AIN(11)) 90,100,100
   90 ISKP(10)=250090
      IERR=15
      GO TO 9999
  100 AIN(11)=(AIN(10)+SQRT(AIN(11)))/AIN(8)
  110 DO 120 I=1,3
  120 PFREI(I)=X(I,2)+AIN(11)*X1(I)
      GO TO 280
  130 IF (ISKP(14)) 180,140,180
  140 CDS(3)=CONST(5)
      GO TO 170
  150 IF (ISKP(14)) 180,160,180
  160 CDS(3)=1.
  170 CALL FLES (CDS,ISKP(31),4H2IFE,14Hp1,p2,Betrag?$)
  180 NTRY=28
      DO 210 NC=1,2
      CALL KPDEK
      IF (IERR) 9999,190,9999
  190 DO 200 I=1,3
  200 X(I,NC)=X2(I)
  210 CONTINUE
      AIN(7)=0.
      DO 220 I=1,3
      AIN(10)=X(I,2)-X(I,1)
      AIN(7)=AIN(7)+AIN(10)*AIN(10)
  220 X(I,3)=AIN(10)
      IF (AIN(7)) 9999,9999,230
  230 IF (NTYP-2) 9999,240,250
  240 AIN(11)=CDS(3)
      GO TO 260
  250 AIN(11)=CDS(3)/SQRT(AIN(7))
  260 DO 270 I=1,3
  270 PFREI(I)=PFREI(I)+X(I,3)*AIN(11)
  280 DO 290 I=1,3
      PTRIKL(I)=TRAINV(I,1)*PFREI(1)+TRAINV(I,2)*PFREI(2)
     1 +TRAINV(I,3)*PFREI(3)+UR(I)
  290 CONTINUE
      GO TO 9999
  300 IAIN(1)=NCDA
      IAIN(2)=NCD
      CALL FLES (AIN,ISKP(31),3H2IE,9Hvon,bis?$)
      IF (IAIN(1)) 330,330,310
  310 IF (IAIN(2)-NCDDM) 320,320,330
  320 IF (IAIN(1)-IAIN(2)) 340,340,330
  330 ISKP(10)=250330
      GO TO 790
  340 NRET=1
      NC=1
      NTRY=40
      IC=IAIN(1)-1
  350 IC=IC+1
      IF (IC-IAIN(2)) 400,400,9999
  360 DO 370 I=1,72
  370 IAIN(I)=0
      CALL FLES (IAIN,ISKP(31),4H72IE,11Hc1,c2,...?$)
      NC=1
      NTRY=24
      NRET=0
      I=0
  380 I=I+1
      IF (IAIN(I)) 9999,9999,390
  390 CDS(1)=AIN(I)
  400 CALL KPDEK
      IF (IERR) 9999,410,9999
  410 IF (NAT-NATDM) 430,420,420
  420 ISKP(10)=250420
      IERR=2
      GO TO 9999
  430 NAT=NAT+1
      AT(1,NAT)=X(1,1)
      AT(2,NAT)=X(2,1)
      AT(3,NAT)=X(3,1)
      AT(4,NAT)=AT(4,IANR)
      AT(5,NAT)=AT(5,IANR)
      AT(6,NAT)=AT(6,IANR)
      IF (NRET) 9999,440,350
  440 IF (I-72) 380,9999,9999
  450 CALL FLES (AIN(3),ISKP(31),3H2FE,5Hx,y?$)
      AIN(5)=ISKP(31)
      CALL KPWPLT (AIN,8)
      IF (NTYP-5) 9999,460,540
  460 XQ=(AIN(1)-CONST(11))/O8
      YP=(AIN(2)-CONST(12))/O9
  470 IF (NCDA-NCD) 500,500,480
  480 ISKP(10)=250480
  490 IERR=12
      GO TO 9999
  500 TEMP2=1.E6
      DO 520 I=NCDA,NCD
      TEMP=HOE/(HOE-ATOMS(3,I))
      TEMP3=ABS(ATOMS(1,I)*TEMP-XQ)+ABS(ATOMS(2,I)*TEMP-YP)
      IF (TEMP2-TEMP3) 520,520,510
  510 TEMP2=TEMP3
      IAIN(1)=I
  520 CONTINUE
      IAIN(2)=IAIN(1)
      ISKP(14)=1
      ISKP(32)=0
      NTYP=4
      CALL KPO
      DO 530 I=1,3
      PTRIKL(I)=X(I,1)
  530 PFREI(I)=X2(I)
      NC=1
      NTRY=1
      CALL KPDEK
      CONST(27)=CDS(1)
      CONST(28)=CDS(1)
      ISKP(14)=0
      GO TO 9999
  540 TEMP=HOE/(HOE-PFREI(3))
      CONST(29)=(AIN(1)-CONST(11))/(O8*TEMP)-PFREI(1)
      CONST(30)=(AIN(2)-CONST(12))/(O9*TEMP)-PFREI(2)
      WRITE (NTOUT,550) CONST(29),CONST(30)
  550 FORMAT (' Verschiebung:',2F7.2)
      GO TO 9999
  560 CALL FLES (AIN,ISKP(31),1HE,2H?$)
      PFREI(1)=PFREI(1)+CONST(29)
      PFREI(2)=PFREI(2)+CONST(30)
      GO TO 280
  570 CALL FLES (CDS,ISKP(31),3H2IE,7Hc1,c2?$)
      IF (ISKP(31)-2) 580,590,590
  580 ISKP(10)=250580
      GO TO 790
  590 NTRY=24
      DO 600 NC=1,2
      CALL KPDEK
      IF (IERR) 9999,600,9999
  600 CONTINUE
      DO 610 I=1,3
  610 X(I,3)=X(I,2)-X(I,1)
      DO 650 I=1,3
      IF (X(I,3)) 620,650,620
  620 DO 630 J=1,3
  630 X(J,1)=X(J,3)/X(I,3)
      WRITE (NTOUT,640) I,(X(J,1),J=1,3)
  640 FORMAT (' (',I1,') ',3F10.5)
  650 CONTINUE
      GO TO 9999
  660 IAIN(1)=1
      IAIN(2)=NAT
      CALL FLES (AIN,ISKP(31),3H2IE,9Hvon,bis?$)
      IF (NCDA-NCD) 680,680,670
  670 ISKP(10)=250670
      GO TO 490
  680 IF (IAIN(1)-IAIN(2)) 690,690,710
  690 IF (IAIN(1)) 710,710,700
  700 IF (IAIN(2)-NATDM) 720,720,710
  710 ISKP(10)=250710
      GO TO 790
  720 DO 730 I=1,3
      X(I,1)=100.
  730 X(I,2)=-100.
      NC=3
      IAIN(1)=IAIN(1)*100000
      IAIN(2)=IAIN(2)*100000+99948
      NTRY=40
      DO 770 IC=NCDA,NCD
      J=ICD(IC)
      IF (J-IAIN(1)) 770,740,740
  740 IF (J-IAIN(2)) 750,750,770
  750 CALL KPDEK
      DO 760 J=1,3
      X(J,1)=AMIN1(X(J,1),X(J,3))
      X(J,2)=AMAX1(X(J,2),X(J,3))
  760 CONTINUE
  770 CONTINUE
      IF (X(1,1)-X(1,2)) 800,800,780
  780 ISKP(10)=250780
  790 IERR=16
      GO TO 9999
  800 DO 810 J=1,3
      X1(J)=(X(J,1)+X(J,2))*.5
      X2(J)=(X(J,2)-X(J,1))*.5
  810 CONTINUE
      WRITE (NTOUT,820) X1,X2
  820 FORMAT (' Ursprung:',3F10.5,' Halbmesser:',3F6.2)
      GO TO 9999
  830 DO 840 I=1,3
  840 AIN(I)=0.
      CALL FLES (AIN,ISKP(31),3H3FE,7Hx,y,z?$)
      DO 850 I=1,3
  850 AIN(I)=AIN(I)+PFREI(I)
      TEMP=HOE/(HOE-AIN(3))
      XQ=AIN(1)*TEMP
      YP=AIN(2)*TEMP
      GO TO 470
  860 AIN(4)=CONST(5)
      IAIN(5)=0
      CALL FLES (AIN,ISKP(31),5H3IFAE,29Hvon,bis,czentr <,fakt <,R>>?$)
      IF (IAIN(1)) 910,910,870
  870 IF (IAIN(2)-NATDM) 880,880,910
  880 IZ2=NAT+1
      IF (IAIN(5) .EQ. KDR) IZ2=IAIN(1)
  890 IF (IZ2) 910,910,900
  900 IF (IZ2+IAIN(2)-IAIN(1)-NATDM) 920,910,910
  910 ISKP(10)=250910
      GO TO 790
  920 IF (IAIN(5) .EQ. KDR) GO TO 930
      NAT=IZ2+IAIN(2)-IAIN(1)
  930 CDS(1)=AIN(3)
      NC=1
      NTRY=24
      CALL KPDEK
      IF (IERR) 9999,940,9999
  940 IF (NTYP-13) 980,950,980
  950 IF (AIN(4)) 970,960,970
  960 ISKP(10)=250960
      GO TO 790
  970 AIN(4)=1./AIN(4)
  980 IZ1=IAIN(1)-1
      GO TO 1010
  990 IZ1=IZ1+1
      DO 1000 I=1,3
      AT(I,IZ2)=(AT(I,IZ1)-X(I,1))*AIN(4)+X(I,1)
      AT(I+3,IZ2)=AT(I+3,IZ1)
 1000 CONTINUE
      IZ2=IZ2+1
 1010 IF (IZ1-IAIN(2)) 990,9999,9999
 9999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPGNKO
                          SUBROUTINE KPGNKO
      DIMENSION ATKO(4),VQK(300),IAIN(72)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (IPK(1),VQK(1)),(AIN(1),IAIN(1))
      DATA BLANK/4H    /,ATKO/1H0,1HX,1HY,1HZ/
      DO 10 I=1,3
   10 AIN(I)=1.2/O8
      CALL FLES (AIN,ISKP(31),3H3FE,10Hl1,l2,l3?$)
      IF (NAT) 200,200,20
   20 DO 30 I=1,NAT
      J=NAT+1-I
      IF (AT(5,J) .NE. ATKO(1)) GO TO 30
      IF (AT(6,J) .EQ. BLANK) GO TO 40
   30 CONTINUE
      GO TO 200
   40 NATS=J
      NAT=J-1
      IAIN(11)=J*100000+55501
      DO 50 I=1,3
      IAIN(11+I)=IAIN(10+I)+100000
      PTRIKL(I)=AT(I,J)
   50 CONTINUE
      IF (NCD-NCDA) 90,60,60
   60 JTO=NCDA-1
      DO 80 IC=NCDA,NCD
      DO 70 I=11,14
      IF (ICD(IC) .EQ. IAIN(I)) GO TO 80
   70 CONTINUE
      JTO=JTO+1
      ICD(JTO)=ICD(IC)
   80 CONTINUE
      NCD=JTO
      K8=0
      K9=0
   90 J=1
      IF (IPKP-1) 200,200,100
  100 JTO=J
      IPKDO=IPK(J)
      INC=8
      IF (IPKDO-2) 120,140,110
  110 IF (IPKDO-5) 170,150,130
  120 INC=4
      GO TO 170
  130 INC=7+IPK(J+6)
      GO TO 170
  140 IF (IPK(J+1) .NE. NATS) GO TO 170
      IF (IPK(J+2) .NE. NATS) GO TO 170
      IF (IPK(J+3) .NE. NATS+1) GO TO 170
      IF (IPK(J+4) .NE. NATS+3) GO TO 170
      GO TO 190
  150 INC=5
      ITMP=IPK(J+1)
      DO 160 I=1,3
      IF (ITMP .EQ. NATS+I) GO TO 190
  160 CONTINUE
  170 J=J+INC
      IF (J .LT. IPKP) GO TO 100
      GO TO 200
  180 IPK(JTO)=IPK(IV)
      JTO=JTO+1
  190 IV=JTO+INC
      IF (IV .LT. IPKP) GO TO 180
      IPKP=JTO
      IF (J .LT. IPKP) GO TO 100
  200 IF (NAT+4-NATDM) 220,220,210
  210 ISKP(10)=520210
      IERR=2
      GO TO 999
  220 DO 240 J=1,4
      K=NAT+J
      DO 230 I=1,3
      AT(I,K)=PTRIKL(I)
  230 CONTINUE
      AT(4,K)=.01
      AT(5,K)=ATKO(J)
      AT(6,K)=BLANK
  240 CONTINUE
      DO 250 J=1,3
  250 AT(J,NAT+J+1)=AT(J,NAT+J+1)+AIN(J)/ZELLE(J)
      IF (NCD+4-NCDDM) 270,270,260
  260 ISKP(10)=520260
      IERR=2
      GO TO 999
  270 DO 280 J=1,4
      NAT=NAT+1
      NCD=NCD+1
      ICD(NCD)=NAT*100000+55501
  280 CONTINUE
      IF (IPKP+23-IPKDM) 300,300,290
  290 ISKP(10)=520290
      IERR=11
      GO TO 999
  300 NTRY=4
      DO 330 NC=1,4
      DO 310 I=1,3
  310 X(I,NC)=AT(I,NAT-4+NC)
      CALL KPDEK
      DO 320 I=1,3
  320 X(I,NC)=X2(I)
  330 CONTINUE
      TEMPL=0.
      DO 370 I=1,3
      TEMP1=X(1,I+1)-X(1,1)
      TEMP2=X(2,I+1)-X(2,1)
      TEMP3=X(3,I+1)-X(3,1)
      TEMP4=TEMP1*TEMP1+TEMP2*TEMP2
      TEMPL=AMAX1(TEMPL,TEMP3*TEMP3+TEMP4)
      IF (TEMP4) 340,340,350
  340 TEMP1=1.5*CONST(15)
      TEMP2=-0.5*CONST(15)
      GO TO 360
  350 TEMP4=SQRT(TEMP4)
      TEMP1=(1.5*TEMP1/TEMP4-0.5)*CONST(15)
      TEMP2=(1.5*TEMP2/TEMP4-0.5)*CONST(15)
  360 IPK(IPKP)=5
      IPK(IPKP+1)=NAT-3+I
      VQK(IPKP+2)=TEMP1
      VQK(IPKP+3)=TEMP2
      VQK(IPKP+4)=CONST(15)
      IPKP=IPKP+5
  370 CONTINUE
      IPK(IPKP)=2
      IPK(IPKP+1)=NAT-3
      IPK(IPKP+2)=NAT-3
      IPK(IPKP+3)=NAT-2
      IPK(IPKP+4)=NAT
      VQK(IPKP+5)=.01
      VQK(IPKP+6)=SQRT(TEMPL)+.1
      VQK(IPKP+7)=.01
      IPKP=IPKP+8
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPGNZL
                          SUBROUTINE KPGNZL
      DIMENSION IAIN(72),INLCDS(8),IT1(3)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1),IATM1),(AIN(2),IATM2)
      DATA INLCDS/55501,65501,56501,55601,66601,56601,65601,66501/
      IATM1=2
      IATM2=2
      CALL FLES (AIN,ISKP(31),3H2IE,7Hn1,n2?$)
      IF (NCD+8-NCDDM) 20,20,10
   10 ISKP(10)=530010
      IERR=2
      GO TO 999
   20 ITEMP1=IATM1*100000
      ICD(NCD+1)=ITEMP1+INLCDS(1)
      ITEMP2=IATM2*100000
      ICD(NCD+5)=ITEMP2+INLCDS(5)
      DO 30 I=2,4
      ICD(NCD+I)=ITEMP2+INLCDS(I)
      ICD(NCD+I+4)=ITEMP1+INLCDS(I+4)
   30 CONTINUE
      NCDSV=NCD
      NCD=NCD+8
      I1=1
      IF (ZELLE(2) .LT. ZELLE(1)) I1=2
      IF (ZELLE(3) .LT. ZELLE(I1)) I1=3
      I2=ID2(I1)
      I3=ID2(I2)
      IF (ZELLE(I3) .GE. ZELLE(I2)) GO TO 40
      I2=I3
      I3=ID2(I1)
   40 I1FLG=0
      I2FLG=0
      ILF1=0
      NTRY=42
   50 ILF1=ILF1+1
      NC=1
      IC=NCDSV+ILF1
      CALL KPDEK
      DO 60 I=1,3
      IT1(I)=IT(I)
      X2(I)=X1(I)
   60 CONTINUE
      ILF2=ILF1
   70 ILF2=ILF2+1
      NC=2
      IC=NCDSV+ILF2
      CALL KPDEK
      J=0
      TEMP=0.
      DO 80 I=1,3
      IF (IT1(I) .NE. IT(I)) J=J+1
      TEMP2=X2(I)-X1(I)
      TEMP=TEMP+TEMP2*TEMP2
   80 CONTINUE
      TEMP2=SQRT(TEMP)
      IF (J .EQ. 3) GO TO 90
      IF (J .NE. 2) GO TO 120
      IF (IATM1 .NE. IATM2) GO TO 120
   90 DO 100 I=1,3
      IF (ABS(ZELLE(I)-TEMP2) .LT. .01) GO TO 220
  100 CONTINUE
      IF (TEMP2 .LT. ZELLE(I2)) GO TO 110
      IF (TEMP2 .GT. ZELLE(I3)) GO TO 120
      I2FLG=1
      GO TO 120
  110 IF (TEMP2 .LT. ZELLE(I1)) GO TO 120
      I1FLG=1
  120 IF (ILF2 .LT. 8) GO TO 70
      IF (ILF1 .LT. 4) GO TO 50
      I=8
      IF (I1FLG .NE. 0) I=I+8
      IF (I2FLG .NE. 0) I=I+8
      IF (IPKP+I - IPKDM) 140,130,130
  130 ISKP(10)=530130
      IERR=11
      GO TO 240
  140 IAIN(11)=2
      IAIN(12)=IATM1
      IAIN(13)=IATM1
      IAIN(14)=IATM2
      IAIN(15)=IATM2
      AIN(16)=ZELLE(I1)-.001
      AIN(17)=ZELLE(I1)+.001
      AIN(18)=.01
      IF (I1FLG) 150,170,150
  150 DO 160 I=11,18
      IPK(IPKP)=IAIN(I)
      IPKP=IPKP+1
  160 CONTINUE
      AIN(16)=ZELLE(I2)-.001
  170 AIN(17)=ZELLE(I2)+.001
      IF (I2FLG) 180,200,180
  180 DO 190 I=11,18
      IPK(IPKP)=IAIN(I)
      IPKP=IPKP+1
  190 CONTINUE
      AIN(16)=ZELLE(I3)-.001
  200 AIN(17)=ZELLE(I3)+.001
      DO 210 I=11,18
      IPK(IPKP)=IAIN(I)
      IPKP=IPKP+1
  210 CONTINUE
      GO TO 999
  220 WRITE (NTOUT,230)
  230 FORMAT (' KPGNZL0230 - Eine Diagonale entspricht einer Gitterkonst
     1anten.')
  240 NCD=NCDSV
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPGOML
                          SUBROUTINE KPGOML
      DIMENSION INBFR(4),DIST(2,25),IDIST(2,25),IAIN(72),IAT(6,200)
      DIMENSION ICDS(7),IATTYP(2,4),IATSRT(6),IOPTT(4)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (INBFR(1),MOLOPT),(INBFR(3),IVON),(INBFR(4),IBIS)
      EQUIVALENCE (INBFR(2),MOLMTH),(AIN(1),IAIN(1))
      EQUIVALENCE (AT(1,1),IAT(1,1)),(DIST(1,1),IDIST(1,1))
      EQUIVALENCE (CDS(1),ICDS(1)),(CONST(31),DISTMX)
      EQUIVALENCE (ISKP(1),IOPTS)
      DATA IELMH/4HH   /,IBLANK/4H    /
      DATA IDSTDM/15/,IDSTRS/15/,IDSTMX/24/,DISTTH/1.2/
      DATA DIST/4HC C ,1.7,4HC N ,1.7,4HC S ,1.9,4HN S ,1.8,4HN N ,1.8,
     1 4HC F ,2.0,4HC CL,2.2,4HC I ,2.3,4HO O ,1.2,4HC O ,1.5,
     2 4HN O ,1.5,4HO S ,1.7,4HF F ,1.7,4HF S ,1.7,4HSNSN,3.0,20*0./
      DATA IATTPO/4/,IATTYP/2HC ,-10,2HN ,-10,2HO ,-10,2HS ,-10/
      DATA IOPTT/4HF A ,4HP S ,4HNFNA,4HNPNS/
      NTYPS=NTYP
      IOPT=IOPTS
      IF (NTYP-2) 10,10,870
   10 IVON=3
      IBIS=NAT
      MOLMTH=0
      MOLOPT=0
      CALL FLES (INBFR,ISKP(31),5HIA2IE,18HRes-Nr,Opt,n1,n2?$)
      IF (IVON) 40,40,20
   20 IF (IBIS-IVON) 40,30,30
   30 IF (IBIS-NAT) 50,50,40
   40 ISKP(10)=540040
      IERR=16
      GO TO 9999
   50 CALL CNVTUP (INBFR,5,4)
      IF (NTYP-2) 70,60,9990
   60 NCD=NCDA-1
      K8=0
      K9=0
   70 ITMP2=0
      IASRPO=0
      ITMP=0
      ISKP(14)=-2
      DO 160 J=IVON,IBIS
      ITMP1=IAT(5,J)
      I=IASRPO
      GO TO 120
   80 IF (LCOMPS(IATSRT,2*I-1,2, ITMP1,1)) 110,90,110
   90 IF (I-IASRPO) 100,160,100
  100 ITMP2=1
      GO TO 160
  110 I=I-1
  120 IF (I) 130,130,80
  130 IF (IASRPO-12) 140,160,160
  140 IF (ITMP1 .NE. IELMH) GO TO 150
      IF (ITMP1 .NE. MOLMTH) GO TO 160
  150 IASRPO=IASRPO+1
      CALL COPYCH (ITMP1,1,2, IATSRT,2*IASRPO-1)
  160 CONTINUE
      IF (IOPT-8) 190,170,170
  170 IOPT=IOPT-8
      IF (ITMP2) 180,190,180
  180 IAIN(1)=IVON
      IAIN(2)=IBIS
      NTYP=5
      CALL KPSRT
      IF (IERR) 9990,190,9990
  190 CONTINUE
      IPLFLG=0
      MOLCNT=0
      NCDSTR=NCD+1
      IF (NTYPS-5) 210,200,210
  200 NTYP=1
      CALL KPADD
      IPLFLG=1
      GO TO 610
  210 IC=IVON
  220 IF (IAT(5,IC) .NE. IELMH) GO TO 230
      IC=IC+1
      IF (IC-IBIS) 220,220,9990
  230 ITMP=IC*100000+55501
      IF (NCD-NCDDM) 250,240,240
  240 ISKP(10)=540240
      IERR=2
      GO TO 9999
  250 NCD=NCD+1
      MOLCNT=MOLCNT+1
      IF (MOLOPT) 280,280,260
  260 IF (MOLOPT-MOLCNT) 280,270,270
  270 MOLSTR=NCD
  280 ICD(NCD)=ITMP
      NCDPOI=NCD
      GO TO 340
  290 IC=NCDPOI+1
      NTRY=32
      CALL KPDEK
      IF (IERR) 9990,300,9990
  300 IF (IAT(5,IANR) .EQ. IELMH) GO TO 450
      IANRUR=IANR
      ISYNUR=ISYNR
      DO 330 IC=1,NCDPOI
      CALL KPDEK
      IF (IERR) 9990,310,9990
  310 IF (IANR-IANRUR) 330,320,330
  320 IF (ISYNR-ISYNUR) 330,440,330
  330 CONTINUE
      NCDPOI=NCDPOI+1
  340 IZLPOI=IVON
  350 ICDS(1)=ICD(NCDPOI)
      IANRUR=ICDS(1)/100000
      CALL COPYCH (AT(5,IANRUR),1,2, ITMP1,1)
      CALL COPYCH (ITMP1,1,2, ITMP2,3)
      IZ1=IZLPOI
      IZ2=IZLPOI
      DQ=0.
      IF (IAT(5,IZLPOI) .NE. IELMH) GO TO 360
      IF (MOLMTH .NE. IELMH) GO TO 400
      DQ=DISTTH
  360 CALL COPYCH (AT(5,IZLPOI),1,2, ITMP1,3)
      CALL COPYCH (ITMP1,3,2, ITMP2,1)
      ITMP=ITMP1
      IF (ITMP2 .LT. ITMP1) ITMP=ITMP2
      CALL CNVTUP (ITMP,1,4)
      DO 370 I=1,IDSTDM
      IF (IDIST(1,I) .NE. ITMP) GO TO 370
      DQ=DIST(2,I)
      GO TO 390
  370 CONTINUE
      IF (DQ) 380,380,390
  380 DQ=DISTMX
  390 NTYP=3
      CONST(20)=0.
      CALL KPAVBR
      IF (IERR) 9990,400,9990
  400 IF (NCD-NCDSTR+1-ISKP(23)) 430,430,410
  410 WRITE (NTOUT,420) NCD
  420 FORMAT (' ',I3,' Atoms found.  Search terminated.',/,
     1 ' Use FMMC command to increase this limit.')
      GO TO 610
  430 IZLPOI=IZLPOI+1
      IF (IZLPOI-IBIS) 350,350,460
  440 IPLFLG=1
  450 NCDPOI=NCDPOI+1
  460 IF (NCDPOI-NCD) 290,470,470
  470 CONTINUE
      IF (MOLOPT) 490,490,480
  480 IF (MOLCNT-MOLOPT) 490,540,540
  490 DO 500 I=1,72
  500 IAIN(I)=0
      IH=1
      DO 510 IC=NCDSTR,NCD
      J=ICD(IC)/100000
      CALL INTCHR (IH,1,IAIN,J)
  510 CONTINUE
      DO 530 IC=IVON,IBIS
      CALL CHRINT (IAIN,IC,1, IH)
      IF (IH) 530,520,530
  520 IF (IAT(5,IC) .NE. IELMH) GO TO 230
  530 CONTINUE
  540 IF (MOLOPT-1) 610,610,550
  550 IF (MOLCNT-MOLOPT) 560,580,580
  560 WRITE (NTOUT,570) MOLOPT
  570 FORMAT (' KPGOML0560 - Residue Nr.',I3,' not found.')
      GO TO 610
  580 K8=0
      K9=0
      J=NCDSTR
      DO 590 I=MOLSTR,NCD
      ICD(J)=ICD(I)
      J=J+1
  590 CONTINUE
      NCD=J-1
  600 MOLCNT=1
  610 NRATMS=NCD-NCDSTR+1
      IF (IPLFLG) 620,640,620
  620 WRITE (NTOUT,630) NRATMS
  630 FORMAT (' Polymeric structure.',I4,
     1 ' atoms will be plotted.')
      GO TO 660
  640 WRITE (NTOUT,650) MOLCNT,NRATMS
  650 FORMAT (' ',I3,' Residues found (',I3,' atoms).')
  660 IF (IOPT-4) 790,670,670
  670 IOPT=IOPT-4
      IPKP=1
      ISKP(14)=1
      IF (IASRPO) 9990,9990,680
  680 DO 740 I=1,IASRPO
      DO 730 K=I,IASRPO
      ITMP2=IBLANK
      CALL COPYCH (IATSRT,2*I-1,2, ITMP2,1)
      IHFLG=-1
      IF (ITMP2 .EQ. IELMH) IHFLG=0
      ITMP1=IBLANK
      CALL COPYCH (IATSRT,2*K-1,2, ITMP1,1)
      IF (ITMP1 .EQ. IELMH) IHFLG=IHFLG+1
      CALL COPYCH (ITMP2,1,2, ITMP1,3)
      CALL COPYCH (ITMP1,1,2, ITMP2,3)
      IF (ITMP2 .LT. ITMP1) ITMP1=ITMP2
      CALL CNVTUP (ITMP1,1,4)
      DO 690 J=1,IDSTDM
      IF (IDIST(1,J) .NE. ITMP1) GO TO 690
      AIN(6)=DIST(2,J)
      GO TO 720
  690 CONTINUE
      IF (IHFLG) 710,700,730
  700 AIN(6)=DISTTH
      GO TO 720
  710 AIN(6)=DISTMX
  720 IAIN(3)=IBLANK
      IAIN(4)=IBLANK
      CALL COPYCH (ITMP1,1,2, AIN,9)
      CALL COPYCH (ITMP1,3,2, AIN,13)
      AIN(5)=0.
      AIN(7)=0.06
      IAIN(8)=IVON
      IAIN(9)=IBIS
      NTYP=8
      CALL KPLPK
      IF (IERR) 9990,730,9990
  730 CONTINUE
  740 CONTINUE
      ITMP1=IBLANK
      DO 780 I=1,IASRPO
      CALL COPYCH (IATSRT,2*I-1,2, ITMP1,1)
      DO 750 J=1,IATTPO
      IF (ITMP1 .NE. IATTYP(1,J)) GO TO 750
      IAIN(2)=IATTYP(2,J)
      GO TO 760
  750 CONTINUE
      IAIN(2)=-10
  760 IAIN(1)=ITMP1
      AIN(3)=0.
      IF (ITMP1 .NE. IELMH) GO TO 770
      AIN(3)=.2
      IAIN(2)=10
  770 IAIN(4)=IVON
      IAIN(5)=IBIS
      NTYP=11
      CALL KPLPK
      IF (IERR) 9990,780,9990
  780 CONTINUE
  790 CONTINUE
      IF (IOPT-2) 850,800,800
  800 IOPT=IOPT-2
      IF (NRATMS-2) 810,810,830
  810 WRITE (NTOUT,820) NRATMS
  820 FORMAT (' KPGOML0820 - Only',I2,
     1 ' atoms found. Scaling impossible.')
      GO TO 9990
  830 IAIN(1)=IVON
      IAIN(2)=IBIS
      NTYP=2
      CALL KPEFIT
      IF (IERR) 9990,840,9990
  840 AIN(11)=6.
      IAIN(12)=2
      AIN(13)=.35
      CALL KPMINO
      IF (IERR) 9990,850,9990
  850 IF (IOPT) 9990,9990,860
  860 NTYP=1
      CALL KPFKTR
      GO TO 9990
  870 IF (NTYP-4) 880,950,970
  880 CALL FLES (IAIN,ISKP(31),4HAAFE,13HAt1,At2,dmx?$)
      IF (ISKP(33)-1) 890,900,900
  890 ISKP(10)=540890
      IERR=16
      GO TO 9999
  900 CALL CNVTUP (AIN,1,8)
      CALL COPYCH (AIN,5,2, AIN,3)
      CALL COPYCH (AIN,1,2, AIN,7)
      ITMP1=IAIN(1)
      IF (IAIN(2) .LT. ITMP1) ITMP1=IAIN(2)
      DO 910 I=1,IDSTDM
      IF (ITMP1 .NE. IDIST(1,I)) GO TO 910
      DIST(2,I)=AIN(3)
      GO TO 9999
  910 CONTINUE
      IF (IDSTDM-IDSTMX) 940,920,920
  920 WRITE (NTOUT,930)
  930 FORMAT (' KPGOML0930 - Too many pairs of atoms.')
      GO TO 9999
  940 IDSTDM=IDSTDM+1
      IDIST(1,IDSTDM)=ITMP1
      DIST(2,IDSTDM)=AIN(3)
      GO TO 9999
  950 IDSTDM=IDSTRS
  960 CALL FLES (AIN,ISKP(31),1HE,2H?$)
      GO TO 9999
  970 IF (NTYP-6) 980,1040,1050
  980 ICDS(4)=1
      ICDS(5)=3
      ICDS(6)=NAT
      CDS(1)=.5
      CDS(2)=.5
      CDS(3)=.5
      CALL FLES (CDS,ISKP(31),5H3F3IE,22Hdx,dy,dz,c(ur),n1,n2?$)
      DO 990 I=1,3
  990 X(I,7)=CDS(I)
      IZ1=ICDS(5)
      IZ2=ICDS(6)
      ICDS(1)=ICDS(4)
      IVON=ICDS(5)
      IBIS=ICDS(6)
      IF (IVON) 1020,1020,1000
 1000 IF (IBIS-NAT) 1010,1010,1020
 1010 IF (IVON-IBIS) 1030,1030,1020
 1020 ISKP(10)=541020
      IERR=16
      GO TO 9999
 1030 MOLMTH=IELMH
      NTRY=24
      NC=1
      CALL KPDEK
      IF (IERR) 9999,60,9999
 1040 CALL FLES (ISKP(23),ISKP(31),2HIE,10HMax. Nr.?$)
      GO TO 9999
 1050 IF (NTYP-8) 1060,1100,9999
 1060 IAIN(1)=IBLANK
      IAIN(2)=IBLANK
      DO 1080 I=1,IDSTDM
      CALL COPYCH (DIST(1,I),1,2, IAIN,1)
      CALL COPYCH (DIST(1,I),3,2, IAIN,5)
      WRITE (NTOUT,1070) IAIN(1),IAIN(2),DIST(2,I)
 1070 FORMAT (' Dist ',2A4,F6.2)
 1080 CONTINUE
      WRITE (NTOUT,1090) DISTMX
 1090 FORMAT (' Default Dist',F7.2)
      GO TO 960
 1100 DO 1110 I=1,4
 1110 IAIN(I)=IBLANK
      CALL FLES (IAIN,ISKP(31),5HAAAAE,27HOpt (S/NS,P/NP,A/NA,F/NF)?$)
      CALL CNVTUP (IAIN,1,16)
      DO 1170 I=1,4
      K=1
      DO 1160 J=1,4
      K2=15-K
      K3=K
      IF (LCOMPS(IAIN(I),1,2, IOPTT,2*J-1)) 1120,1140,1120
 1120 IF (LCOMPS(IAIN(I),1,2, IOPTT,2*J+7)) 1150,1130,1150
 1130 K3=0
 1140 CONTINUE
      IOPTS=LAND(IOPTS,K2)
      IOPTS=IOPTS+K3
 1150 K=K*2
 1160 CONTINUE
 1170 CONTINUE
      GO TO 9999
 9990 ISKP(14)=0
 9999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPGTY
                          SUBROUTINE KPGTY
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),KTYP)
      DATA KDP,KDF,KDA,KDB,KDC,KDI,KDR,KDZ/1HP,1HF,1HA,1HB,1HC,1HI,
     1 1HR,1HZ/,KDQ/1HQ/,KDL/1HL/,KDS/1HS/
      IF (ISKP(14)) 30,10,30
   10 CALL FLES (KTYP,ISKP(31),2HAE,5HTyp?$)
      IF (NSYM) 20,20,30
   20 ISKP(10)=80020
      IERR=5
      GO TO 999
   30 NSYMS=NSYM
      CALL CNVTUP (KTYP,1,1)
      IF (KTYP-KDP) 40,999,40
   40 IEND=NSYM
      NTYP=0
      IF (KTYP-KDA) 60,50,60
   50 J=5
      K=9
      GO TO 140
   60 IF (KTYP-KDB) 80,70,80
   70 J=1
      K=9
      GO TO 140
   80 IF (KTYP-KDC) 100,90,100
   90 J=1
      K=5
      GO TO 140
  100 IF (KTYP-KDF) 220,110,220
  110 NTYP=1
      GO TO 50
  120 NTYP=2
      GO TO 70
  130 NTYP=0
      GO TO 90
  140 DO 210 I=1,IEND
      IF (NSYM-NSYMDM) 150,420,420
  150 NSYM=NSYM+1
      DO 160 M=1,12
  160 SYM(M,NSYM)=SYM(M,I)
      TEMP=SYM(J,I)+.5
      IF (TEMP-1.) 180,170,170
  170 TEMP=TEMP-1.
  180 SYM(J,NSYM)=TEMP
      TEMP=SYM(K,I)+.5
      IF (TEMP-1.) 200,190,190
  190 TEMP=TEMP-1.
  200 SYM(K,NSYM)=TEMP
  210 CONTINUE
      IF (NTYP-1) 999,120,130
  220 IF (KTYP-KDI) 290,230,290
  230 DO 280 I=1,IEND
      IF (NSYM-NSYMDM) 240,420,420
  240 NSYM=NSYM+1
      DO 250 M=1,12
  250 SYM(M,NSYM)=SYM(M,I)
      DO 270 J=1,9,4
      TEMP=SYM(J,NSYM)+.5
      IF (TEMP-1.) 270,260,260
  260 TEMP=TEMP-1.
  270 SYM(J,NSYM)=TEMP
  280 CONTINUE
      GO TO 999
  290 IF (KTYP-KDR) 340,300,340
  300 DO 330 J=2,3
      DO 330 I=1,IEND
      IF (NSYM-NSYMDM) 310,420,420
  310 NSYM=NSYM+1
      K=ID2(J)
      L=ID2(K)
      J1=(J-1)*4
      K1=(K-1)*4
      L1=(L-1)*4
      DO 320 M=1,4
      SYM(M,NSYM)=SYM(J1+M,I)
      SYM(M+4,NSYM)=SYM(K1+M,I)
  320 SYM(M+8,NSYM)=SYM(L1+M,I)
  330 CONTINUE
      GO TO 999
  340 IF (KTYP-KDZ) 430,360,430
  350 ISKP(10)=80350
      IERR=14
      GO TO 999
  360 DO 410 I=1,IEND
      IF (NSYM-NSYMDM) 370,420,420
  370 NSYM=NSYM+1
      DO 380 M=1,12
  380 SYM(M,NSYM)=-SYM(M,I)
      DO 400 J=1,9,4
      IF (SYM(J,NSYM)) 390,400,400
  390 SYM(J,NSYM)=SYM(J,NSYM)+1.
  400 CONTINUE
  410 CONTINUE
      GO TO 999
  420 ISKP(10)=80420
      IERR=3
      NSYM=NSYMS
      GO TO 999
  430 IF (KTYP-KDQ) 440,460,440
  440 IF (KTYP-KDS) 550,450,550
  450 AIN(9)=.3333333
      GO TO 470
  460 AIN(9)=.6666667
  470 AIN(1)=.3333333
      AIN(5)=.6666667
      IEND=NSYM
      DO 540 J=1,2
      DO 530 I=1,IEND
      IF (NSYM-NSYMDM) 480,420,420
  480 NSYM=NSYM+1
      DO 490 M=1,12
  490 SYM(M,NSYM)=SYM(M,I)
      DO 520 L=1,9,4
      TEMP=SYM(L,NSYM)+AIN(L)
      IF (TEMP-1.) 510,500,500
  500 TEMP=TEMP-1.
  510 SYM(L,NSYM)=TEMP
  520 CONTINUE
  530 CONTINUE
      AIN(5)=1.-AIN(5)
      AIN(1)=1.-AIN(1)
      AIN(9)=1.-AIN(9)
  540 CONTINUE
      GO TO 999
  550 IF (KTYP-KDL) 350,560,350
  560 IEND=NSYM-1
      I=NSYM
      IF (IEND-1) 20,20,570
  570 DO 680 J=2,IEND
      IF (NSYM-NSYMDM) 580,420,420
  580 NSYM=NSYM+1
      DO 590 K=1,12
  590 SYM(K,NSYM)=0.
      LA=-3
      DO 670 L=1,3
      LA=LA+4
      MA=-4
      DO 610 M=1,3
      MA=MA+4
      TEMP=SYM(LA+M,I)
      DO 600 K=1,4
      KA=LA+K-1
  600 SYM(KA,NSYM)=SYM(KA,NSYM)+TEMP*SYM(MA+K,J)
  610 CONTINUE
      TEMP=SYM(LA,NSYM)+SYM(LA,I)
      GO TO 630
  620 TEMP=TEMP-1.
  630 IF (TEMP-.95) 650,650,620
  640 TEMP=TEMP+1.
  650 IF (TEMP+.08) 640,640,660
  660 SYM(LA,NSYM)=TEMP
  670 CONTINUE
  680 CONTINUE
      GO TO 999
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPGTYA
                          SUBROUTINE KPGTYA
      DIMENSION TRAVEC(3,4)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),KD),(AIN(2),N1),(AIN(3),N2)
      DATA TRAVEC/.5,.5,.0, .5,.0,.5, .0,.5,.5, .5,.5,.5/
      DATA IBLANK/4H    /,KDI,KDF/4HI   ,4HF   /
      KD=IBLANK
      CALL COPYCH (ISKP(16),1,1, AIN,1)
      N1=3
      N2=NAT
      CALL FLES (AIN,ISKP(31),4HA2IE,13HTyp,von,bis?$)
      IF (N1-N2) 10,10,30
   10 IF (N1) 30,30,20
   20 IF (N2-NAT) 50,50,30
   30 ISKP(10)=380030
   40 IERR=16
      GO TO 999
   50 CALL CNVTUP (KD,1,1)
      IF (KD-KDI) 70,60,70
   60 L1=4
      L2=4
      M=1
      GO TO 90
   70 IF (KD-KDF) 30,80,30
   80 L1=1
      L2=3
      M=3
   90 LPOI=(N2-N1+1)*M+NAT
      IF (LPOI-NATDM) 110,110,100
  100 ISKP(10)=380100
      IERR=2
      GO TO 999
  110 I=LPOI
      GO TO 140
  120 DO 130 K=1,6
  130 AT(K,LPOI)=AT(K,NAT)
      LPOI=LPOI-1
      NAT=NAT-1
  140 IF (NAT-N2) 150,150,120
  150 NAT=I
      I=N2
  160 DO 170 J=L1,L2
      AT(1,LPOI)=AT(1,I)+TRAVEC(1,J)
      AT(2,LPOI)=AT(2,I)+TRAVEC(2,J)
      AT(3,LPOI)=AT(3,I)+TRAVEC(3,J)
      AT(4,LPOI)=AT(4,I)
      AT(5,LPOI)=AT(5,I)
      AT(6,LPOI)=AT(6,I)
      LPOI=LPOI-1
  170 CONTINUE
      DO 180 J=1,6
  180 AT(J,LPOI)=AT(J,I)
      LPOI=LPOI-1
      I=I-1
      IF (I-N1) 999,160,160
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--KPHMSD
                   SUBROUTINE KPHMSD (MNAR,NBRAS)
      DIMENSION IGTY(8),IAIN(72),MNAR(*),NBRAS(*)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1))
      DATA IGTY/1HF,1HA,1HB,1HC,1HI,1HQ,0,1HS/,IBLANK/4H    /
      I=0
      IF (ISKP(14)) 5,5,30
   5  ISKP(16)=IBLANK
      ISKP(17)=IBLANK
      ISKP(18)=0
      IF (NTYP-2) 10,20,999
   10 CALL FLES (ISKP(16),ISKP(31),3H2AE,12HHMS-Symbol?$)
      CALL ASCE (ISKP(16),1,8)
      I=0
      GO TO 30
   20 CALL FLES (ISKP(18),ISKP(31),2HIE,20HSpace group number?$)
      I=1
   30 CALL DB2292 (MNAR,NBRAS,ISKP(16),I,SYM,NSYM,NSYMDM,NBGTYP,IRC)
      CALL EBCA (ISKP(16),1,8)
      IF (IRC) 150,150,40
   40 GO TO (50,50,70,90,90,110,110,110),IRC
   50 WRITE (NTOUT,60) (ISKP(I),I=16,18)
   60 FORMAT (' KPHMS060 - HMS ',2A4,' / SGR-No.',I6,' not provided.')
      GO TO 999
   70 WRITE (NTOUT,80) (ISKP(I),I=16,18)
   80 FORMAT (' KPHMS080 - HMS ',2A4,' / SGR-No.',I6,' not unique.')
      GO TO 999
   90 WRITE (NTOUT,100)
  100 FORMAT (' KPHMSD100 - Swap failed. Invalid info on tables file.')
      IRC=-2
      GO TO 999
  110 WRITE (NTOUT,120) IRC
  120 FORMAT (' KPHMS120 - RC from DB2292 =',I3)
      IRC=-2
      GO TO 999
  130 WRITE (NTOUT,140) IAIN(1)
  140 FORMAT (' KPHMSD140 - Symmetries used without Bravais lattice type
     1.',/,' ',12X,'Use  GTYA ',A1,' / NGLP  commands.')
      GO TO 999
  150 IF (NBGTYP) 999,999,160
  160 N=2
      IF (NBGTYP .EQ. 1) N=4
      IF (NBGTYP .EQ. 6) N=3
      IF (NBGTYP .EQ. 8) N=3
      IAIN(1)=IGTY(NBGTYP)
      IF (NSYM*N .GT. NSYMDM) GO TO 130
      ISKP14=ISKP(14)
      ISKP(14)=1
      CALL KPGTY
      ISKP(14)=ISKP14
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880505--KPK
                          SUBROUTINE KPK
      INTEGER CDS
      DIMENSION SAVK(3,4),SAVTRA(3,3),SAVUR(3),INBFR(3)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),I),(AIN(2),G),(AIN(3),J),(AIN(4),K)
      EQUIVALENCE (AIN(5),TEMP),(CONST(3),BOG)
      DATA SAVK/1.,3*0.,1.,3*0.,1.,3*0./
      DATA SAVTRA/1.,3*0.,1.,3*0.,1./,SAVUR/3*0./
      DATA INBFR/0,0,0/,KDR/1HR/
      K9=0
      GO TO (10,420,360,500,530,560,580,610,630,670,770,840),NTYP
   10 ASSIGN 90 TO NRET
      IF (ISKP(14)) 60,20,60
   20 CDS(2)=0
      CDS(4)=0
      CALL FLES (CDS,ISKP(31),3H5IE,27Hcur <,cx1,cx2 <,cy1,cy2>>?$)
      IF (ISKP(31)-1) 50,60,30
   30 IF (ISKP(31)-3) 50,60,40
   40 IF (ISKP(31)-5) 50,60,50
   50 ISKP(10)=110050
      GO TO 990
   60 NTRY=24
      NC=1
      CALL KPDEK
      IF (IERR) 999,70,999
   70 DO 80 I=1,3
   80 UR(I)=X(I,NC)
      GO TO NRET, (90,650)
   90 IF (CDS(2)) 100,999,100
  100 NZC=5
      IF (CDS(4)) 120,110,120
  110 NZC=3
  120 DO 130 NC=2,NZC
      CALL KPDEK
      IF (IERR) 999,130,999
  130 CONTINUE
  140 DO 150 I=1,3
  150 X(I,1)=X(I,3)-X(I,2)
      IF (NZC-5) 180,160,180
  160 DO 170 I=1,3
  170 X(I,2)=X(I,5)-X(I,4)
  180 NTRY=2
      NC=1
      CALL KPDEK
      DO 190 I=1,3
      DREH(1,I)=X1(I)
  190 X2(I)=0.
      IF (NZC-3) 260,200,260
  200 I=1
      IF (ABS(X1(2))-ABS(X1(1))) 210,220,220
  210 I=2
  220 IF (ABS(X1(3))-ABS(X1(I))) 230,240,240
  230 I=3
  240 X2(I)=1.
      DO 250 I=1,3
  250 X1(I)=X2(I)
      GO TO 270
  260 NC=2
      CALL KPDEK
  270 DO 280 I=1,3
      J=ID2(I)
      K=ID2(J)
      DREH(3,I)=DREH(1,J)*X1(K)-DREH(1,K)*X1(J)
      X2(I)=0.
  280 CONTINUE
  290 DO 310 I=1,3
      J=ID2(I)
      K=ID2(J)
      DREH(2,I)=DREH(3,J)*DREH(1,K)-DREH(3,K)*DREH(1,J)
      DO 300 J=1,3
      X2(J)=DREH(J,I)*DREH(J,I)+X2(J)
  300 CONTINUE
  310 CONTINUE
      DO 350 I=1,3
      TEMP=SQRT(X2(I))
      IF (TEMP) 320,320,330
  320 ISKP(10)=110320
      IERR=6
      GO TO 999
  330 DO 340 J=1,3
      DREH(I,J)=DREH(I,J)/TEMP
  340 CONTINUE
  350 CONTINUE
  360 DO 380 I=1,3
      DO 370 J=1,3
      TRA(I,J)=DREH(I,1)*DG(1,J)+DREH(I,2)*DG(2,J)+DREH(I,3)*DG(3,J)
      TRAINV(J,I)=DREH(I,1)*RG(1,J)+DREH(I,2)*RG(2,J)
     1           +DREH(I,3)*RG(3,J)
  370 CONTINUE
  380 CONTINUE
      IF (NTYP-9) 999,390,999
  390 IF (TRA(1,1)*UR(1)+TRA(1,2)*UR(2)+TRA(1,3)*UR(3)) 999,999,400
  400 DO 410 I=1,3
      DREH(1,I)=-DREH(1,I)
      DREH(2,I)=-DREH(2,I)
  410 CONTINUE
      NTYP=1
      GO TO 360
  420 IF (ISKP(14)) 460,430,460
  430 AIN(2)=CONST(6)
      CALL FLES (AIN,ISKP(31),3HIFE,21HAchse,Winkel (Grad)?$)
      IF (I) 450,450,440
  440 IF (I-3) 460,460,450
  450 ISKP(10)=110450
      IERR=7
      GO TO 999
  460 J=ID2(I)
      K=ID2(J)
      DO 470 L=1,3
      DO 470 M=1,3
  470 TRA(L,M)=0.
      TRA(I,I)=1.
      TEMP=COS(G*BOG)
      TRA(J,J)=TEMP
      TRA(K,K)=TEMP
      TEMP=SIN(G*BOG)
      TRA(K,J)=TEMP
      TRA(J,K)=-TEMP
      DO 480 I=1,3
      DO 480 J=1,3
      S(I,J)=TRA(I,1)*DREH(1,J)+TRA(I,2)*DREH(2,J)+TRA(I,3)*DREH(3,J)
  480 CONTINUE
      DO 490 I=1,3
      DO 490 M=1,3
  490 DREH(I,M)=S(I,M)
      GO TO 360
  500 DO 520 I=1,3
      DO 510 J=1,3
      SAVTRA(I,J)=TRA(I,J)
  510 SAVK(I,J)=DREH(I,J)
      SAVUR(I)=UR(I)
  520 SAVK(I,4)=UR(I)
      GO TO 999
  530 DO 550 I=1,3
      DO 540 J=1,3
  540 DREH(I,J)=SAVK(I,J)
  550 UR(I)=SAVK(I,4)
      GO TO 360
  560 DO 570 I=1,3
      UR(I)=PTRIKL(I)
  570 PFREI(I)=0.
      GO TO 999
  580 DO 600 I=1,3
      DO 590 J=1,3
      TEMP=SAVK(I,J)
      SAVK(I,J)=DREH(I,J)
  590 DREH(I,J)=TEMP
      TEMP=SAVK(I,4)
      SAVK(I,4)=UR(I)
  600 UR(I)=TEMP
      GO TO 360
  610 DO 620 I=1,3
      TEMP=DREH(1,I)
      DREH(1,I)=DREH(2,I)
      DREH(2,I)=DREH(3,I)
      DREH(3,I)=TEMP
  620 CONTINUE
      GO TO 360
  630 ASSIGN 650 TO NRET
      CALL FLES (CDS,ISKP(31),3H3IE,11Hcur,e1,e2?$)
      IF (ISKP(31)-3) 640,60,60
  640 ISKP(10)=110640
      GO TO 990
  650 N1=CDS(2)
      N2=CDS(3)
      DO 660 I=1,3
      J=ID2(I)
      K=ID2(J)
      DREH(1,I)=AT(J,N1)*AT(K,N2)-AT(K,N1)*AT(J,N2)
      DREH(3,I)=AT(I,N1)
      X2(I)=0.
  660 CONTINUE
      GO TO 290
  670 CALL FLES (INBFR,ISKP(31),4H2IAE,13Hvon,bis(,R)?$)
      IF (INBFR(1)) 700,700,680
  680 IF (INBFR(2)-NATDM) 690,690,700
  690 IF (INBFR(1)-INBFR(2)) 710,710,700
  700 ISKP(10)=110700
      GO TO 990
  710 IZL=NAT
      IF (INBFR(3) .EQ. KDR) IZL=INBFR(1)-1
      IVON=INBFR(1)
  720 IZL=IZL+1
      DO 730 I=1,3
  730 X1(I)=AT(I,IVON)-SAVUR(I)
      DO 740 I=1,3
  740 X2(I)=SAVTRA(I,1)*X1(1)+SAVTRA(I,2)*X1(2)+SAVTRA(I,3)*X1(3)
      DO 750 I=1,3
      AT(I,IZL)=TRAINV(I,1)*X2(1)+TRAINV(I,2)*X2(2)+TRAINV(I,3)*X2(3)
     1 +UR(I)
      AT(I+3,IZL)=AT(I+3,IVON)
  750 CONTINUE
      IVON=IVON+1
      IF (IVON-INBFR(2)) 720,720,760
  760 IF (INBFR(3) .NE. KDR) NAT=IZL
      GO TO 999
  770 CALL FLES (X,ISKP(31),3H9FE,17Hm11,m12,...,m33?$)
      TEMP=0.
      DO 780 I=1,3
      J=ID2(I)
      K=ID2(J)
      TEMP=TEMP+X(1,I)*X(2,J)*X(3,K)-X(3,I)*X(2,J)*X(1,K)
  780 CONTINUE
      IF (ABS(TEMP-1.)-.0001) 810,810,790
  790 WRITE (NTOUT,800) TEMP
  800 FORMAT (' KPK0800 Determinante:',E12.6,' nicht 1.')
      GO TO 999
  810 DO 830 I=1,3
      DO 820 J=1,3
      DREH(I,J)=X(I,J)
  820 CONTINUE
  830 CONTINUE
      GO TO 360
  840 DO 850 I=1,3
  850 UR(I)=X(I,1)
      NZC=5
      GO TO 140
  990 IERR=16
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPLABL
                          SUBROUTINE KPLABL
      DIMENSION IAIN(72)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ INTCDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1))
   10 IF (ISKP(14)) 60,20,60
   20 IAIN(2)=0
      AIN(5)=CONST(15)
      CALL FLES (AIN,ISKP(31),8H2I3F10AE,27Hc1,c2,xoff,yoff,size,text?$)
      CONST(15)=AIN(5)
      IF (ISKP(33)) 30,30,40
   30 ISKP(10)=320030
      IERR=16
      GO TO 999
   40 IF (IAIN(2)) 50,50,60
   50 IAIN(2)=IAIN(1)
   60 NTRY=28
      DO 85 NC=1,2
      INTCDS(NC)=IAIN(NC)
      CALL KPDEK
      IF (IERR) 999,70,999
   70 DO 80 J=1,3
   80 X(J,NC)=X2(J)
   85 CONTINUE
      DO 90 J=1,3
   90 X(J,3)=(X(J,1)+X(J,2))*.5
      TEMP = HOE/(HOE-X(3,3))
      AIN(2)=(X(1,3)+AIN(3))*TEMP*O8+CONST(11)
      AIN(3)=(X(2,3)+AIN(4))*TEMP*O9+CONST(12)
      AIN(4)=AIN(5)*TEMP*O9
      IF (ISKP(26)) 110,100,110
  100 AIN(5)=ISKP(33)*4
      CALL KPWPLT (AIN(2),11)
      GO TO 999
  110 IAIN(5)=ISKP(33)*4
      CALL KPPCHR (AIN(2),AIN(3),AIN(6),IAIN(5),AIN(4))
      CALL KPWPLT (AIN,0)
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--KPLENT
                 SUBROUTINE KPLENT (IOPT,MNAR,IAR,NBRAS)
      DIMENSION IAIN(72),IOPT(8),MNAR(*),IAR(*),NBRAS(*),TFTAB(3)
      COMMON /DC2201/ IFLAG(50)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      COMMON /TFKTRN/ ANTFKT(9,200),NTFKT,NTFDM
      EQUIVALENCE (AIN(1),IAIN(1)),(IBLK,BLANK)
CHP8  DATA IBLK/'    '/,IKOMMA/',   '/,IBUZ/'Z   '/
      DATAIBLK/Z'40404040'/,IKOMMA/Z'6B404040'/,IBUZ/Z'E9404040'/
      DATA TFTAB/0.,3.,8./,IUNBLK/4H    /
      ISKP(14)=1
      DO 10 I=1,18
   10 TITEL(I)=BLANK
      CALL DB2252 (4,1,IAR,NBRAS,NRC)
      IF (NRC) 30,30,20
   20 CALL DB2256 (1,TITEL,72,LEN,NBRAS)
      CALL EBCA (TITEL,1,72)
   30 CALL DB2252 (8,1,IAR,NBRAS,NRC)
      IF (NRC) 40,40,60
   40 WRITE (NTOUT,50)
   50 FORMAT (' KPLENT050 - Missing cell parameters.')
      GO TO 100
   60 DO 90 I=1,6
      CALL DB2259 (2*I-1,ZELLE(I),NRC,NBRAS)
      IF (NRC) 70,90,90
   70 WRITE (NTOUT,80)
   80 FORMAT (' KPLENT080 - Invalid cell parameters.')
   90 CONTINUE
      NTYP=1
      CALL KPZ
  100 CALL DB2252 (9,1,IAR,NBRAS,NRC)
      IF (NRC) 150,150,110
  110 CONTINUE
      ISKP(16)=IBLK
      ISKP(17)=IBLK
      ISKP(18)=0
      IZNFLG=-1
      CALL DB2256 (1,ISKP(16),8,LEN,NBRAS)
      IF (LEN) 150,150,120
  120 NTYP=1
      IF (IFLAG(36)-1) 140,130,140
  130 CALL DB2258 (3,IZNFLG,NRC,NBRAS)
      IF (NRC) 160,150,160
  140 CALL KPHMSD (MNAR,NBRAS)
      IF (NSYM) 150,150,360
  150 CALL DB2252 (10,1,IAR,NBRAS,NRC)
      IF (NRC) 160,160,180
  160 WRITE (NTOUT,170)
  170 FORMAT (' KPLENT170 - No symmetry information.')
      GO TO 360
  180 WRITE (NTOUT,190)
  190 FORMAT (' KPLENT190 - Symmetry information from SYM records.')
      I=1
      GO TO 210
  200 ISKP(31)=18
      CALL EBCA (IAIN,1,80)
      CALL KPSYDC
      I=I+1
      CALL DB2252 (10,I,IAR,NBRAS,NRC)
      IF (NRC) 260,260,210
  210 DO 220 J=1,20
      IAIN(J)=IBLK
  220 CONTINUE
      J=1
      JPOI=0
      GO TO 240
  230 JPOI=JPOI+1
      CALL COPYCH (IKOMMA,1,1, AIN,JPOI)
  240 JPOII=(JPOI+7)/4
      JPOI=(JPOII-1)*4+1
      CALL DB2256 (J,IAIN(JPOII),48,LEN,NBRAS)
      IF (LEN) 200,200,250
  250 CONTINUE
      JPOI=JPOI+LEN
      J=J+1
      IF (J-3) 230,230,200
  260 IF (IZNFLG-2) 280,270,280
  270 CALL COPYCH (IBUZ,1,4, IAIN,1)
      CALL KPGTY
      IF (IERR) 300,280,300
  280 IF (IFLAG(36)-1) 290,360,290
  290 IAIN(1)=IUNBLK
      CALL COPYCH (ISKP(16),1,1, AIN,1)
      CALL KPGTY
      IF (IERR) 330,360,300
  300 IF (IERR-3) 330,310,330
  310 WRITE (NTOUT,320)
  320 FORMAT (' KPLENT320 - Too many symmetries.  Use GTYA command.')
      GO TO 350
  330 WRITE (NTOUT,340) IAIN(1)
  340 FORMAT (' KPLENT340 - Invalid Bravais type ',A1)
  350 IERR=0
  360 NAT=2
      CALL DB2252 (12,1,IAR,NBRAS,NRC)
      IF  (NRC) 370,370,390
  370 WRITE (NTOUT,380)
  380 FORMAT (' KPLENT380 - Atomic coordinates not given')
      GO TO 999
  390 I=1
      GO TO 450
  400 NAT=NAT+1
      AT(5,NAT)=BLANK
      AT(6,NAT)=BLANK
      CALL DB2260 (1,AT(5,NAT),4,LEN,NBRAS)
      CALL DB2260 (2,AT(6,NAT),4,LEN,NBRAS)
      CALL EBCA (AT(5,NAT),1,8)
      DO 430 J=1,3
      CALL DB2259 (2*J+4,AT(J,NAT),NRC,NBRAS)
      IF (NRC) 420,410,410
  410 IF (ABS(AT(J,NAT))-2.) 430,430,420
  420 NAT=NAT-1
      GO TO 440
  430 CONTINUE
      AT(4,NAT)=0.3
  440 I=I+1
      CALL DB2252 (12,I,IAR,NBRAS,NRC)
      IF (NRC) 480,480,450
  450 IF (NAT-NATDM) 400,460,460
  460 WRITE (NTOUT,470)
  470 FORMAT (' KPLENT470 - Too many atomic parameters.')
  480 IF (IFLAG(22)) 490,999,490
  490 ITFPOI=13
  500 I=0
      GO TO 540
  510 NTFKT=NTFKT+1
      ANTFKT(1,NTFKT)=BLANK
      ANTFKT(2,NTFKT)=BLANK
      DO 520 J=3,8
  520 ANTFKT(J,NTFKT)=0.
      ANTFKT(9,NTFKT)=TFTAB(ITFPOI-12)
      CALL DB2260 (1,ANTFKT(1,NTFKT),4,LEN,NBRAS)
      CALL DB2260 (2,ANTFKT(2,NTFKT),4,LEN,NBRAS)
      CALL EBCA (ANTFKT(1,NTFKT),1,8)
      DO 530 J=3,8
      CALL DB2259 (2*J-3,ANTFKT(J,NTFKT),NRC,NBRAS)
      IF (NRC) 540,530,530
  530 CONTINUE
  540 I=I+1
      CALL DB2252 (ITFPOI,I,IAR,NBRAS,NRC)
      IF (NRC) 550,550,560
  550 ITFPOI=ITFPOI+1
      IF (ITFPOI-15) 500,500,999
  560 IF (NTFKT-NTFDM) 510,570,570
  570 WRITE (NTOUT,580)
  580 FORMAT (' KPLENT580 - Too many temperature factors.')
  999 IOPT(8)=IFLAG(31)
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD880408--KPLPK
                          SUBROUTINE KPLPK
      DIMENSION IAIN(72),IAT(6,200),IPLD(4)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ ICDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1)),(AT(1,1),IAT(1,1))
      EQUIVALENCE (CONST(27),IPLD(1))
      DATA IBLANK/4H    /
      IF (NTYP-1) 9999,10,100
   10 IF (ISKP(14)) 30,20,40
   20 IAIN(1)=1
      IAIN(2)=NAT
      IAIN(3)=ISKP(8)
   30 CALL FLES (IAIN,ISKP(31),3H3IE,15Hvon,bis,npkte?$)
   40 IF (IABS(IAIN(3))-2) 60,50,50
   50 IF (IABS(IAIN(3))-30) 70,70,60
   60 ISKP(10)=120060
      GO TO 440
   70 IF (IPKP+3-IPKDM) 90,90,80
   80 ISKP(10)=120080
      GO TO 470
   90 IPK(IPKP  )=1
      IPK(IPKP+1)=IAIN(1)
      IPK(IPKP+2)=IAIN(2)
      IPK(IPKP+3)=IAIN(3)
      IPKP=IPKP+4
      GO TO 9999
  100 IF (NTYP-5) 110,210,280
  110 IF (ISKP(14)) 130,120,160
  120 AIN(6)=0.
      AIN(7)=.06
  130 CALL FLES (AIN,ISKP(31),5H4I3FE,25Hu1,u2,z1,z2,dmin,dmax,r?$)
      IF (ISKP(31)-4) 150,140,140
  140 IF (ISKP(32)) 150,150,160
  150 ISKP(10)=120150
      GO TO 440
  160 IF (IPKP+7-IPKDM) 170,170,80
  170 IF (AIN(6)-AIN(5)) 180,190,190
  180 AIN(8)=AIN(6)
      AIN(6)=AIN(5)
      AIN(5)=AIN(8)
  190 IPK(IPKP  )=NTYP
      DO 200 I=1,7
  200 IPK(IPKP+I)=IAIN(I)
      IPKP=IPKP+8
      GO TO 9999
  210 IF (ISKP(14)) 230,220,250
  220 IAIN(1)=IPLD(1)
      IAIN(2)=IPLD(3)
      IAIN(3)=IPLD(4)
      AIN(4)=CONST(15)
  230 CALL FLES (AIN,ISKP(31),4HI3FE,22Hcode,xoff,yoff,schrh?$)
      IPLD(1)=IAIN(1)
      ICDS(1)=IAIN(1)
      NC=1
      NTRY=16
      CALL KPDEK
      IF (IERR) 9999,240,9999
  240 CONST(15)=AIN(4)
      IAIN(1)=ICDS(1)
      IPLD(3)=IAIN(2)
      IPLD(4)=IAIN(3)
  250 IF (IPKP+4-IPKDM) 260,260,80
  260 IPK(IPKP)=5
      DO 270 I=1,4
  270 IPK(IPKP+I)=IAIN(I)
      IPKP=IPKP+5
      GO TO 9999
  280 IF (NTYP-7) 290,540,540
  290 IF (ISKP(14)) 330,300,360
  300 IAIN(1)=IPLD(1)
      IAIN(2)=IPLD(2)
      IF (ISKP(19)) 320,310,320
  310 IAIN(2)=0
  320 IAIN(3)=IPLD(3)
      IAIN(4)=IPLD(4)
      AIN(5)=CONST(15)
  330 CALL FLES (AIN,ISKP(31),8H2I3F16AE,
     1 28Hc1,c2,xoff,yoff,schrh,text?$)
      IF (ISKP(14)) 340,360,360
  340 IF (ISKP(33)) 350,350,360
  350 ISKP(33)=ISKP(34)
  360 CONST(15)=AIN(5)
      IF (IAIN(2)) 370,370,380
  370 AIN(2)=AIN(1)
  380 NTRY=16
      DO 400 NC=1,2
      IPLD(NC+2)=IAIN(NC+2)
      IPLD(NC)=IAIN(NC)
      ICDS(NC)=IAIN(NC)
      CALL KPDEK
      IF (IERR) 9999,390,9999
  390 IAIN(NC)=ICDS(NC)
  400 CONTINUE
      IF (ISKP(19)) 420,420,410
  410 J=ISKP(19)
      GO TO 450
  420 J=ISKP(33)
      IF (J) 430,430,450
  430 ISKP(10)=120430
  440 IERR=16
      GO TO 9999
  450 NANZ=7+J
      IF (IPKP +NANZ-1-IPKDM) 480,480,460
  460 ISKP(10)=120460
  470 IERR=11
      GO TO 9999
  480 IPK(IPKP)=6
      DO 490 I=1,5
  490 IPK(IPKP+I)=IAIN(I)
  500 IPK(IPKP+6)=J
  510 DO 520 I=1,J
  520 IPK(IPKP+6+I)=IAIN(I+5)
  530 IPKP=IPKP+NANZ
      GO TO 9999
  540 IF (NTYP-10) 550,790,790
  550 IF (ISKP(14)) 570,560,580
  560 AIN(5)=CONST(31)
      AIN(6)=0.
      AIN(7)=.06
      IAIN(8)=1
      IAIN(9)=NAT
  570 CALL FLES (AIN(3),ISKP(31),7HAA3F2IE,
     1 27Hsur,szl,dmin,dmax,r,n1,n2?$)
  580 NTYP=NTYP-5
      NATPS=MAX0(IAIN(8),1)
      NATPE=MIN0(IAIN(9),NATDM)
      DO 590 I=3,4
  590 CALL CNVTUP (IAIN(I),1,4)
  600 IF (AIN(6)-AIN(5)) 610,620,620
  610 AIN(8)=AIN(6)
      AIN(6)=AIN(5)
      AIN(5)=AIN(8)
  620 JPOI=7
      IPOI=7
      ISYMBL=IAIN(3)
  630 I=NATPS-1
  640 IF (I-NATPE) 650,690,690
  650 I=I+1
      II=IAT(5,I)
      CALL CNVTUP (II,1,4)
      IF (II .NE. ISYMBL) GO TO 640
      IPOI=IPOI+1
      IAIN(IPOI)=I
  660 IMERK=I
      IF (I-NATPE) 670,680,680
  670 I=I+1
      II=IAT(5,I)
      CALL CNVTUP (II,1,4)
      IF (II .EQ. ISYMBL) GO TO 660
  680 IPOI=IPOI+1
      IAIN(IPOI)=IMERK
      GO TO 640
  690 IF (IPOI-JPOI) 9999,9999,700
  700 IF (IAIN(3) .NE. IAIN(4)) GO TO 710
      IPOIE=IPOI
      GO TO 730
  710 IF (JPOI-7) 9999,720,730
  720 JPOI=IPOI
      IPOIE=JPOI
      ISYMBL=IAIN(4)
      GO TO 630
  730 I=8
  740 J=JPOI+1
      IF (JPOI .EQ. 7) J=I
      IAIN(1)=IAIN(I)
      IAIN(2)=IAIN(I+1)
  750 IAIN(3)=IAIN(J)
      IAIN(4)=IAIN(J+1)
      IF (IPKP+7-IPKDM) 760,760,80
  760 IPK(IPKP)=NTYP
      DO 770 K=1,7
  770 IPK(IPKP+K)=IAIN(K)
      IPKP=IPKP+8
      J=J+2
      IF (J-IPOI) 750,750,780
  780 I=I+2
      IF (I-IPOIE) 740,740,9999
  790 IF (NTYP-11) 800,910,1040
  800 IF (ISKP(14)) 830,810,840
  810 DO 820 I=1,4
  820 IAIN(I)=0
      AIN(5)=20.
      AIN(6)=160.
      AIN(7)=15.
      AIN(8)=.08
      AIN(9)=.24
      IAIN(10)=10
  830 CALL FLES (AIN,ISKP(31),6H3I6FIE,
     1 31Hc1,c2,c3,ra,w1,w2,w3,r1,r2,ns?$)
  840 DO 850 I=1,3
      J=IAIN(I)
      IF (J) 870,870,850
  850 CONTINUE
      IF (IPKP+10-IPKDM) 880,880,860
  860 ISKP(10)=120860
      GO TO 470
  870 ISKP(10)=120870
      GO TO 440
  880 IPK(IPKP)=7
  890 DO 900 I=1,10
  900 IPK(IPKP+I)=IAIN(I)
      IPKP=IPKP+11
      GO TO 9999
  910 IF (ISKP(14)) 940,920,940
  920 IAIN(1)=IBLANK
      IAIN(2)=ISKP(8)
      AIN(3)=0.
      IAIN(4)=1
      IAIN(5)=NAT
      CALL FLES (AIN,ISKP(31),6HAIF2IE,20Hsymbol,nst,r,n1,n2?$)
      IF (IABS(IAIN(2))-2) 930,940,940
  930 ISKP(10)=120930
      GO TO 440
  940 CALL CNVTUP (IAIN(1),1,4)
      I=IAIN(4)-1
  950 I=I+1
      IF (I-IAIN(5)) 960,960,9999
  960 II=IAT(5,I)
      CALL CNVTUP (II,1,4)
      IF (IAIN(1) .NE. II) GO TO 950
      J=I
      GO TO 990
  970 J=J+1
      IF (J-IAIN(5)) 980,980,1010
  980 II=IAT(5,J)
      CALL CNVTUP (II,1,4)
      IF (IAIN(1) .NE. II) GO TO 1010
  990 IF (AIN(3)) 970,970,1000
 1000 AT(4,J)=AIN(3)
      GO TO 970
 1010 IF (IPKP+3-IPKDM) 1030,1030,1020
 1020 ISKP(10)=121020
      GO TO 470
 1030 IPK(IPKP)=1
      IPK(IPKP+1)=I
      IPK(IPKP+2)=J-1
      IPK(IPKP+3)=IAIN(2)
      IPKP=IPKP+4
      I=J
      GO TO 950
 1040 IF (ISKP(14)) 1060,1050,1090
 1050 AIN(10)=0.
 1060 CALL FLES (AIN,ISKP(31),9H4I2F2I2FE,
     1 39Hu1,u2, z1,z2, dmin,dmax, c1,c2, dn,dx?$)
      IF (ISKP(14)) 1090,1070,1090
 1070 IF (ISKP(34)) 1080,1080,1090
 1080 ISKP(10)=121080
      GO TO 440
 1090 IF (AIN(10)) 1100,1100,1110
 1100 AIN(10)=AIN(9)
      AIN(9)=0.
 1110 IF (IPKP+10-IPKDM) 1120,1120,860
 1120 IPK(IPKP)=NTYP-4
      GO TO 890
 9999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--KPMACR
                          SUBROUTINE KPMACR
      DIMENSION IAIN(72),INBF(7),ANBF(7),FLDORG(6)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1))
      EQUIVALENCE (INBF(1),NPKTE),(INBF(2),IACHSE),(INBF(6),ISTRT)
      EQUIVALENCE (INBF(7),IEND)
      EQUIVALENCE (INBF(1),ANBF(1))
      DATA KDUNDF/4HUNDF/,BLANK/4H    /
      DATA IBU0/48/
      NTYPS=NTYP
      ISKP(25)=0
      GO TO (20,170, 10,10), NTYPS
   10 ISKP(25)=1
   20 ISKP(14)=1
      DO 30 I=1,6
   30 FLDORG(I)=0.
      IF (ISKP(13)) 40,50,40
   40 FLDORG(4)=CONST(9)
      FLDORG(6)=-CONST(9)
      GO TO 60
   50 FLDORG(3)=CONST(8)
      FLDORG(5)=-CONST(8)
   60 IF (ISKP(7)) 70,80,70
   70 CALL KPWPLT (AIN,6)
   80 IF (NTYPS-3) 90,90,100
   90 NTYP=2
      IAIN(1)=2
      AIN(2)=CONST(13)*.5
      CALL KPK
      IF (NTYPS-3) 110,100,110
  100 NTYP=2
      IAIN(1)=3
      CALL KPSRT
  110 NTYP=1
      CALL KPEXPU
      IF (NTYPS-3) 120,120,160
  120 CALL KPWPLT (FLDORG(3),5)
      NTYP=2
      IAIN(1)=2
      AIN(2)=-CONST(13)
      CALL KPK
      IF (NTYPS-3) 140,130,140
  130 NTYP=2
      IAIN(1)=3
      CALL KPSRT
  140 NTYP=1
      CALL KPEXPU
  150 NTYP=2
      IAIN(1)=2
      AIN(2)=CONST(13)*.5
      CALL KPK
      CALL KPWPLT (FLDORG(5),5)
  160 CALL FLES (AIN,ISKP(31),1HE,2H?$)
      GO TO 290
  170 ISTRT=1
      IEND=0
      INBF(3)=KDUNDF
      INBF(4)=1
      ANBF(5)=.3
      CALL FLES (INBF,ISKP(31),8H2IAIF2IE,
     1 38Hnpkte,iachse,name,iuntr,r,istrt,iend?$)
      IUNT=INBF(4)
      IF (NPKTE) 180,180,190
  180 ISKP(10)=340180
      IERR=16
      GO TO 999
  190 IF (IEND) 200,200,210
  200 IEND=NPKTE
  210 AIN(2)=360./FLOAT(NPKTE)
      IAIN(1)=IACHSE
      ISKP(14)=1
      NTYP=5
      DO 280 I=1,NPKTE
      IF (I-ISTRT) 260,220,220
  220 IF (NAT-NATDM) 240,230,230
  230 ISKP(10)=340230
      IERR=2
      GO TO 290
  240 NAT=NAT+1
      DO 250 J=1,3
  250 AT(J,NAT)=PTRIKL(J)
      AT(4,NAT)=ANBF(5)
      AT(5,NAT)=ANBF(3)
      ANBF(4)=BLANK
      CALL INTCHR (MOD(IUNT/10,10)+IBU0,1,ANBF(4),1)
      CALL INTCHR (MOD(IUNT   ,10)+IBU0,1,ANBF(4),2)
      IUNT=IUNT+1
      AT(6,NAT)=ANBF(4)
  260 IF (I-IEND) 270,290,290
  270 CALL KPGE01
      IF (IERR) 290,280,290
  280 CONTINUE
  290 ISKP(14)=0
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPMINO
                          SUBROUTINE KPMINO
      DIMENSION DRSV(3,3),DRMRK(3,3)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(11),STEP),(AIN(12),IBIS),(AIN(13),DISTKR)
      EQUIVALENCE (AIN(16),DISTQ),(AIN(17),TEMP),(AIN(18),TEMP2)
      EQUIVALENCE (AIN(21),DRSV(1,1)),(AIN(31),DRMRK(1,1))
      EQUIVALENCE (AIN(19),IDX),(AIN(20),IDY)
      EQUIVALENCE (AIN(30),SUM),(AIN(40),SMIN)
      IF (ISKP(14)) 20,10,20
   10 STEP=6.
      IBIS=2
      DISTKR=.25
      CALL FLES (AIN(11),ISKP(31),4HFIFE,20HSchrittw.,npt,dist?$)
   20 DISTQ=DISTKR*DISTKR
      IF (NCDA-NCD) 40,30,30
   30 ISKP(10)=470030
      IERR=12
      GO TO 999
   40 DO 50 I=1,3
      DO 50 J=1,3
      DRSV(I,J)=DREH(I,J)
   50 DRMRK(I,J)=DREH(I,J)
      SMIN=1.E6
      ICNT=0
      IDX=0
      IDY=0
      GO TO 120
   60 ICNT=ICNT+1
      IDX=ICNT
   70 IDY=ICNT
   80 IF (IABS(IDX)-ICNT) 90,100,100
   90 IF (IABS(IDY)-ICNT) 260,100,100
  100 TEMP=FLOAT(IDX)*STEP*CONST(3)
      SX=SIN(TEMP)
      CX=COS(TEMP)
      TEMP=FLOAT(IDY)*STEP*CONST(3)
      SY=SIN(TEMP)
      CY=COS(TEMP)
      S(1,1)=CY
      S(1,2)=0.
      S(1,3)=SY
      S(2,1)=SX*SY
      S(2,2)=CX
      S(2,3)=-SX*CY
      S(3,1)=-CX*SY
      S(3,2)=SX
      S(3,3)=CX*CY
      DO 110 I=1,3
      DO 110 J=1,3
      DREH(I,J)=S(I,1)*DRSV(1,J)+S(I,2)*DRSV(2,J)+S(I,3)*DRSV(3,J)
  110 CONTINUE
      NTYP=3
      CALL KPK
      K9=0
  120 NTYP=9
      CALL KPGE02
      K9=0
      DO 150 I=NCDA,NCD
      TEMP=HOE-ATOMS(3,I)
      IF (TEMP) 130,130,140
  130 ISKP(10)=470130
      IERR=18
      GO TO 999
  140 ATOMS(1,I)=ATOMS(1,I)*HOE/TEMP
      ATOMS(2,I)=ATOMS(2,I)*HOE/TEMP
  150 CONTINUE
      SUM=0.
      IEND=NCD-1
      DO 220 I=NCDA,IEND
      JSTRT=I+1
      DO 210 J=JSTRT,NCD
      TEMP=ATOMS(1,I)-ATOMS(1,J)
      IF (ABS(TEMP)-DISTKR) 160,160,210
  160 TEMP2=ATOMS(2,I)-ATOMS(2,J)
      IF (ABS(TEMP2)-DISTKR) 170,170,210
  170 FDIST=TEMP*TEMP+TEMP2*TEMP2
      IF (FDIST-DISTQ) 180,200,210
  180 IF (FDIST - 0.0001) 190,190,200
  190 SUM=SUM+20000.-FDIST*1.E8
      GO TO 210
  200 SUM=SUM+1./FDIST
  210 CONTINUE
  220 CONTINUE
  230 IF (SUM-SMIN) 240,260,260
  240 SMIN=SUM
      DO 250 I=1,3
      DO 250 J=1,3
  250 DRMRK(I,J)=DREH(I,J)
      IF (SUM) 290,290,260
  260 IDY=IDY-1
      IF (IDY+ICNT) 270,90,90
  270 IDX=IDX-1
      IF (IDX+ICNT) 280,70,70
  280 IF (ICNT-IBIS) 60,310,310
  290 CONTINUE
      GO TO 999
  310 CONTINUE
      DO 330 I=1,3
      DO 330 J=1,3
  330 DREH(I,J)=DRMRK(I,J)
      NTYP=3
      CALL KPK
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880531--KPO
                          SUBROUTINE KPO
      INTEGER IAIN(72),IAT(6,200),DB2210,KOPT(22)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1),L),(AIN(2),M),(AT(1,1),IAT(1,1))
      DATA KOPT/4HNOKD,3HOKD,4HNTSO,3HTSO,3HNAO,2HAO,3HNPO,2HPO,4HNPLT,
     1 3HPLT,4HNRRI,4HCRRI,3HRRI,3HNOI,2HOI,4HAGLP,3HGLP,4HNGLP,4HCHHP,
     2 4HCHPL,3HNPR,2HPR/
      DATA IBLANK/4H    /
      GO TO (10,40,120,230,420,440,530,710,730,750),NTYP
   10 TEMP=DG(1,1)*DG(2,2)*DG(3,3)
      DO 20 I=1,3
      J=ID2(I)
      K=ID2(J)
      T(K)=ACOS((RG(1,I)*RG(1,J)+RG(2,I)*RG(2,J)+RG(3,I)*RG(3,J))
     1      /(RK(I)*RK(J)))*CONST(4)
   20 CONTINUE
      WRITE (NTOUT,30) ZELLE,TEMP,RK,T
   30 FORMAT ('0Gitterkonstanten:',/,6F10.4,'   Vol =',F10.2,/,' a* =',
     1 F8.5,' b* =',F8.5,' c* =',F8.5,' al* =',F7.2,' be* =',F7.2,
     2 ' ga* =',F7.2)
      GO TO 990
   40 IF (NSYM) 50,50,60
   50 ISKP(10)=130050
      IERR=5
      GO TO 999
   60 ISYNR=DB2210(0)
      WRITE (NTOUT,70) ISKP(18),ISKP(16),ISKP(17)
   70 FORMAT (' Rg Nr',I6,2X,2A4)
      WRITE (NTOUT,80)
   80 FORMAT ('0Symmetrien:',/,' Nr ---------X---------  ---------Y-----
     1----  ---------Z---------')
      DO 110 ISYNR=1,NSYM
      WRITE (NTOUT,90) ISYNR,(SYM(I,ISYNR),I=1,12)
   90 FORMAT (I3,3(F7.3,3F4.1,2X))
      IF (ISKP(20)) 990,100,990
  100 IF (DB2210(1)) 990,110,990
  110 CONTINUE
      GO TO 990
  120 L=1
      M=NAT
      CALL FLES (AIN,ISKP(31),3H2IE,14H<von <,bis>>?$)
      IF (ISKP(31)-1) 140,130,140
  130 M=L
  140 IF (L) 170,170,150
  150 IF (M-NATDM) 160,160,170
  160 IF (L-M) 180,180,170
  170 ISKP(10)=130170
      IERR=16
      GO TO 999
  180 I=DB2210(0)
      WRITE (NTOUT,190)
  190 FORMAT ('0Atome:',/,'  Nr  Name',10X,'x',9X,'y',9X,'z',5X,'r')
      DO 220 I=L,M
      WRITE (NTOUT,200) I,AT(5,I),AT(6,I),(AT(J,I),J=1,4)
  200 FORMAT (I4,2X,   2A4,3F10.6,F5.2)
      IF (ISKP(20)) 990,210,990
  210 IF (DB2210(1)) 990,220,990
  220 CONTINUE
      GO TO 999
  230 IF (ISKP(14)) 300,240,300
  240 L=NCDA
      M=NCD
      DO 250 I=3,7
  250 IAIN(I)=IBLANK
      CALL FLES (IAIN,ISKP(31),8H2JAAAAAE,25H<von <,bis>> <symb,...>?$)
      IF (ISKP(31)-1) 270,260,270
  260 M=L
  270 CALL CNVTUP (IAIN(3),1,20)
  280 IF (L-M) 300,300,290
  290 ISKP(10)=130290
      IERR=12
      GO TO 999
  300 IF (L) 320,320,310
  310 IF (M-NCDDM) 330,330,320
  320 ISKP(10)=130320
      IERR=16
      GO TO 999
  330 NTRY=44
      NC=1
      IC=DB2210(0)
      WRITE (NTOUT,340)
  340 FORMAT ('0Codes:',/,'  Nr   Name     Code     trikline Koordinaten
     1       freie Koordinaten')
      DO 410 IC=L,M
      CALL KPDEK
      AIN(9)=AT(5,IANR)
      CALL CNVTUP (AIN(9),1,4)
      IF (ISKP(32)) 380,380,350
  350 DO 370 I=3,7
  360 IF (IAIN(9) .EQ. IAIN(I)) GO TO 380
  370 CONTINUE
      GO TO 410
  380 WRITE (NTOUT,390) IC,AT(5,IANR),AT(6,IANR),ICD(IC),
     1 (X(I,1),I=1,3),(X2(I),I=1,3)
  390 FORMAT (I4,2X,2A4,I9,2X,3F8.5,3X,3F8.3)
      IF (ISKP(20)) 999,400,999
  400 IF (DB2210(1)) 999,410,999
  410 CONTINUE
      GO TO 999
  420 WRITE (NTOUT,430) TITEL
  430 FORMAT (1H0,18A4)
      GO TO 990
  440 L=NCDA
      M=NCD
      CALL FLES (AIN,ISKP(31),3H2IE,14H<von <,bis>>?$)
      IF (ISKP(31)-1) 460,450,460
  450 M=L
  460 IF (L-M) 480,480,470
  470 ISKP(10)=130470
      IERR=16
      GO TO 999
  480 NTRY=40
      NC=1
      IC=DB2210(0)
      WRITE (NTOUT,490)
  490 FORMAT ('0Codes:',/,'  Nr   Name     Code     trikline Koordinaten
     1       Gitterkoordinaten')
      DO 520 IC=L,M
      CALL KPDEK
      X2(1)=X(1,1)*GRID(1)
      X2(2)=X(2,1)*GRID(2)
      X2(3)=X(3,1)*GRID(3)
      WRITE (NTOUT,500) IC,AT(5,IANR),AT(6,IANR),ICD(IC),
     1 (X(I,1),I=1,3),(X2(I),I=1,3)
  500 FORMAT (I4,2X,2A4,I9,2X,3F8.5,3X,3F8.1)
      IF (ISKP(20)) 999,510,999
  510 IF (DB2210(1)) 999,520,999
  520 CONTINUE
      GO TO 999
  530 IPOI=0
      DO 700 I=1,NAT
      ISYMBL=IAT(5,I)
      IF (IPOI) 560,560,540
  540 DO 550 J=1,IPOI
      IF (ISYMBL .EQ. IAIN(J)) GO TO 700
  550 CONTINUE
  560 IF (IPOI-72) 590,570,570
  570 WRITE (NTOUT,580)
  580 FORMAT (' KPO0580 -
     1 Tabelle voll.  Mit SRTN Parameter sortieren.')
      GO TO 990
  590 IPOI=IPOI+1
      IAIN(IPOI)=ISYMBL
      J=I
      JPOI=IPOI
      GO TO 650
  600 J=J+1
  610 IF (JPOI-71) 620,570,570
  620 JPOI=JPOI+2
      IAIN(JPOI-1)=JMERK
      IAIN(JPOI)=1-J
  630 IF (J-NAT) 640,680,680
  640 J=J+1
      IF (ISYMBL .NE. IAT(5,J)) GO TO 630
  650 JMERK=J
  660 IF (J-NAT) 670,600,610
  670 J=J+1
      IF (ISYMBL .EQ. IAT(5,J)) GO TO 660
      GO TO 610
  680 JMERK=IPOI+1
      WRITE (NTOUT,690) IAIN(IPOI),(IAIN(J),J=JMERK,JPOI)
  690 FORMAT (' ',A4,14I4,/,(5X,14I4))
  700 CONTINUE
      GO TO 990
  710 WRITE (NTOUT,720) NTIN,NTOUT,NTPCH,NTSCR,NTXR1,NTXR2,NTBILF,
     1 NTDTEI,NTTEMP,NAT,NCDA,NCD
  720 FORMAT (' NTIN NTOUT NTPCH NTSCR NTXR1 NTXR2 NTBILF NTDTEI NTTEMP
     1  AE   CA   CE',/,I5,5I6,3I7,3I5)
      GO TO 990
  730 WRITE (NTOUT,740) KOPT(ISKP(2)+1), KOPT(ISKP(4)+3),
     1 KOPT(ISKP(5)+5), KOPT(ISKP(6)+7), KOPT(ISKP(7)+9),
     2 KOPT(ISKP(11)+11), KOPT(ISKP(12)+14), KOPT(ISKP(15)+17),
     3 KOPT(ISKP(26)+19),ISKP(23),ISKP(13),ISKP(1),KOPT(ISKP(3)+21)
  740 FORMAT (' Gesetzte Optionen:',9(' ',A4),/,' FMMC=',I3,' STPO=',I2,
     1 ' FMOPT=',I3,3X,A4)
      GO TO 990
  750 WRITE (NTOUT,760) ((DREH(I,J),J=1,3),I=1,3)
  760 FORMAT (' Matrix DREH: ',3F10.6,/,(14X,3F10.6))
  990 CALL FLES (AIN,ISKP(31),1HE,2H?$)
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--KPORTN
                          SUBROUTINE KPORTN
      DIMENSION HA(3),HB(3)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (S(1,1),HA(1)),(S(1,2),HB(1)),(CDS(1),B1),(CDS(2),B2)
      EQUIVALENCE (CDS(3),B3),(CDS(4),B4),(CONST(4),RAD)
      HA(1)=0.
      HA(2)=DREH(3,3)
      HA(3)=-DREH(3,2)
      B1=HA(2)*HA(2)+HA(3)*HA(3)
      IF (B1) 10,10,20
   10 HA(2)=1.
      GO TO 90
   20 B1=SQRT(B1)
      DO 30 I=1,3
   30 HA(I)=HA(I)/B1
      IF (HA(2)+1.) 40,50,50
   40 HA(2)=-1.
      GO TO 70
   50 IF (HA(2)-1.) 70,70,60
   60 HA(2)=1.
   70 CONTINUE
      B1=ACOS(HA(2))*RAD
      IF (HA(3)) 90,90,80
   80 B1=-B1
   90 HB(1)=0.
      HB(2)=-HA(3)
      HB(3)=HA(2)
      B3=0.
      DO 110 I=1,3
      J=ID2(I)
      K=ID2(J)
      B3=B3+HB(I)*DREH(3,I)
      T(I)=HB(J)*DREH(3,K)-HB(K)*DREH(3,J)
      IF (T(I)) 100,110,100
  100 B4=HA(I)/T(I)
  110 CONTINUE
      IF (B3-1.) 130,120,120
  120 B2=0.
      GO TO 170
  130 IF (B3+1.) 140,140,150
  140 B2=180.
      GO TO 170
  150 CONTINUE
      B2=ACOS(B3)*RAD
      IF (B4) 170,160,160
  160 B2=-B2
  170 B3=0.
      DO 190 I=1,3
      J=ID2(I)
      K=ID2(J)
      B3=B3+HA(I)*DREH(2,I)
      T(I)=HA(J)*DREH(2,K)-HA(K)*DREH(2,J)
      IF (T(I)) 180,190,180
  180 B4=DREH(3,I)/T(I)
  190 CONTINUE
      IF (B3-1.) 210,200,200
  200 B3=0.
      GO TO 250
  210 IF (B3+1.) 220,220,230
  220 B3=180.
      GO TO 250
  230 CONTINUE
      B3=ACOS(B3)*RAD
      IF (B4) 250,240,240
  240 B3=-B3
  250 WRITE (NTOUT,260) B1,B2,B3,UR
  260 FORMAT (' Drehung  1',F8.2,' 2',F8.2,' 3',F8.2,' Urspr:',3F8.5)
  999 RETURN
      END
C ----------------------------------------OWNUNC411----UPD880527--KPPCHR
                 SUBROUTINE KPPCHR (X,Y,LTXT,NLET,SH)
      INTEGER*2 IADTAB(128)
      DIMENSION IZBUF(271),LTXT(*),PLTKOO(2)
      DIMENSION IZBU1(71),IZBU2(79),IZBU3(37),IZBU4(84)
      EQUIVALENCE (IZBUF(1),IZBU1(1)),(IZBUF(72),IZBU2(1))
      EQUIVALENCE (IZBUF(151),IZBU3(1)),(IZBUF(188),IZBU4(1))
      DATA IADTAB/32*0,1,840,1008,952,798,896,820,992,781,864,
     1 854,792,881,795,769,916,600,618,625,640,661,666,681,700,
     2 705,730,761,873,777,1002,924,928,964,2,9,29,44,58,66,73,
     3 92,104,113,123,132,136,142,148,168,180,201,216,233,240,
     4 252,256,262,268,276,1049,1080,1054,892,948,948,284,304,
     5 314,325,340,354,365,382,396,406,420,429,436,456,468,484,
     6 500,517,529,548,557,568,572,578,584,592,1060,816,1070,
     7 1028,928/
      DATA IH/0/
Cmw       DATA IZBU1/Z'FEFF037E',Z'E3FD26C6',Z'FF0EBEDD',Z'ECEBDAB9',
Cmw     1Z'29FDB9D8',Z'E7E5D4B3',Z'03FD232E',Z'FFECCD9E',Z'6E3D1C0A',
Cmw     2Z'07153463',Z'93C4E5FF',Z'0E8EBDDC',Z'EBE6D5B4',Z'8303FD23',
Cmw     3Z'2EFFEE0E',Z'03E3FD09',Z'B9FFEE0E',Z'03FD09B9',Z'FFECCD9E',
Cmw     4Z'6E3D1C0A',Z'07153463',Z'93C4E5FD',Z'A9E9E3FF',Z'0E03FD09',
Cmw     5Z'E9FDEEE3',Z'FF000000',Z'4EAEFD7E',Z'73FD43A3',Z'FF061534',
Cmw     6Z'6383B4D5',Z'E6EEFF0E',Z'03FD06EE',Z'FD48E3FF',Z'0E03E3FF',
Cmw     7Z'030E79EE',Z'E3FF030E',Z'E3EEFF00',Z'EADCCD9E',Z'5E2D1C0A',
Cmw     8Z'07152453',Z'93C4D5E7',Z'EAFF0000',Z'0EBEDDEB',Z'D9B828FD',
Cmw     9Z'2E23FF00',Z'EADCCD9E',Z'5E2D1C0A',Z'07152453',Z'93C4D5E7',
Cmw     AZ'EAFDA5E3',Z'FF0EBEDD',Z'EBD9B828',Z'FD2E23FD',Z'88E3FF00',
Cmw     BZ'ECDDAE4E',Z'1D0C0B1A',Z'D7E6E5D4',Z'A3431405',Z'FF0EEEFD',
Cmw     CZ'7E73FF00',Z'0E071534',Z'6383B4D5',Z'E7EEFF00',Z'0E73EEFF',
Cmw     DZ'0E4379A3',Z'EEFF0EE3',Z'FD03EEFF',Z'0E79EEFD',Z'7973FF00',
Cmw     EZ'0EEE03E3',Z'FF000000'/
       DATA IZBU1/Z'7E03FFFE',Z'C626FDE3',Z'DDBE0EFF',Z'B9DAEBEC',
     1Z'D8B9FD29',Z'B3D4E5E7',Z'2E23FD03',Z'9ECDECFF',Z'0A1C3D6E',
     2Z'63341507',Z'FFE5C493',Z'DCBD8E0E',Z'B4D5E6EB',Z'23FD0383',
     3Z'0EEEFF2E',Z'09FDE303',Z'0EEEFFB9',Z'B909FD03',Z'9ECDECFF',
     4Z'0A1C3D6E',Z'63341507',Z'FDE5C493',Z'FFE3E9A9',Z'09FD030E',
     5Z'E3EEFDE9',Z'000000FF',Z'7EFDAE4E',Z'A343FD73',Z'341506FF',
     6Z'D5B48363',Z'0EFFEEE6',Z'EE06FD03',Z'FFE348FD',Z'FFE3030E',
     7Z'EE790E03',Z'0E03FFE3',Z'00FFEEE3',Z'9ECDDCEA',Z'0A1C2D5E',
     8Z'53241507',Z'E7D5C493',Z'0000FFEA',Z'EBDDBE0E',Z'FD28B8D9',
     9Z'00FF232E',Z'9ECDDCEA',Z'0A1C2D5E',Z'53241507',Z'E7D5C493',
     AZ'E3A5FDEA',Z'DDBE0EFF',Z'28B8D9EB',Z'FD232EFD',Z'00FFE388',
     BZ'4EAEDDEC',Z'1A0B0C1D',Z'D4E5E6D7',Z'051443A3',Z'FDEE0EFF',
     CZ'00FF737E',Z'3415070E',Z'D5B48363',Z'00FFEEE7',Z'FFEE730E',
     DZ'A379430E',Z'E30EFFEE',Z'FFEE03FD',Z'FDEE790E',Z'00FF7379',
     EZ'E303EE0E',Z'000000FF'/
Cmw       DATA IZBU2/Z'C9BA8B4B',Z'1A080614',Z'4383B4C5',Z'FDCBC4D3',
Cmw     1Z'E3FF0000',Z'0E03A3D4',Z'E6E8DAAB',Z'0BFFEABB',Z'4B1A0806',
Cmw     2Z'1443B3E4',Z'FFEABB4B',Z'1A080614',Z'43B3E4EE',Z'E3FF0000',
Cmw     3Z'07E7E8DA',Z'AB4B1A08',Z'061443C3',Z'E4FFCCBD',Z'9E7E5D4C',
Cmw     4Z'40FD3888',Z'FFE4D343',Z'1406081A',Z'4BDBEAFD',Z'EBE2D1A0',
Cmw     5Z'40FF0E03',Z'FD07192A',Z'5B9BCAD9',Z'E7E3FF00',Z'4B8B83FD',
Cmw     6Z'8D8E7E7D',Z'8DFF4B8B',Z'81705041',Z'FD8D8E7E',Z'7D8DFF00',
Cmw     7Z'0E03FD05',Z'EBFD78E3',Z'FF5E5463',Z'8394FF00',Z'0B03FD09',
Cmw     8Z'1A3B4B6A',Z'7973FD79',Z'8AABBBDA',Z'E9E3FF00',Z'0B03FD09',
Cmw     9Z'1A4BABDA',Z'E8E3FF00',Z'9B5B2A19',Z'07152453',Z'93C4D5E7',
Cmw     AZ'D9CA9BFF',Z'0B00FD0A',Z'1B9BCAD9',Z'E7D5C493',Z'1304FF00',
Cmw     BZ'E9DAAB5B',Z'2A190715',Z'245393D4',Z'E5FDEBE0',Z'FF0B2B23',
Cmw     CZ'FD293A6B',Z'ABDAE9E8',Z'FFE9DAAB',Z'4B1A0918',Z'47A7D6E5',
Cmw     DZ'D4A34314',Z'05FF0000',Z'5E547393',Z'B4FD3BBB',Z'FF0B0614',
Cmw     EZ'43A3D4E5',Z'FDEBE3FF',Z'0B73EBFF',Z'0B4378A3',Z'EBFF0BE3',
Cmw     FZ'FD03EBFF',Z'0B73FDEB',Z'5130FF00',Z'0BEB03E3',Z'FF000000'/
Cmw       DATA IZBU3/Z'8E6E4D3C',Z'2A273544',Z'6383A4B5',Z'C7CABCAD',
Cmw     1Z'8EFF3B8E',Z'83FD33C3',Z'FF0B0C1D',Z'4EAEDDEC',Z'EBDAC903',
Cmw     2Z'E3FF0000',Z'0C1D4EAE',Z'DDECEBDA',Z'A969FDA9',Z'D8E7E5D4',
Cmw     3Z'A3431405',Z'FFB3BE06',Z'E6FFEE0E',Z'091A4BAB',Z'DAE8E6D4',
Cmw     4Z'A3431405',Z'FF8E3C1A',Z'08061443',Z'A3D4E6E7',Z'D9AA4A19',
Cmw     5Z'08FF0000',Z'0C0EEE33',Z'FF491807',Z'051443A3',Z'D4E5E7D8',
Cmw     6Z'A9491A0B',Z'0C1D4EAE',Z'DDECEBDA',Z'A9FFE9D8',Z'A747180A',
Cmw     7Z'0B1D4EAE',Z'DDEBE9D7',Z'B56353FF'/
Cmw       DATA IZBU4/Z'D9AA4A19',Z'071544A4',Z'D5FD7B73',Z'FF788899',
Cmw     1Z'8A7A6978',Z'FD738394',Z'85756473',Z'FFEA07E4',Z'FFAE8D6B',
Cmw     2Z'59586684',Z'A3FF0000',Z'7B73FD07',Z'E7FFCBBC',Z'8D6D3C2B',
Cmw     3Z'2A49A8C7',Z'C6B58464',Z'352627FD',Z'7E73FF00',Z'E7B49343',
Cmw     4Z'24151627',Z'AABBBCAD',Z'8E6E4D3C',Z'3B4AE4FF',Z'77879E6E',
Cmw     5Z'77FD7383',Z'94857564',Z'73FF07E7',Z'FD23CBFD',Z'2BC3FF00',
Cmw     6Z'4E6D8B99',Z'98866443',Z'FF788899',Z'8A7A6978',Z'FD837364',
Cmw     7Z'75859493',Z'7183FF00',Z'08E8E5FF',Z'6A7B7D6E',Z'3E2D2B3A',
Cmw     8Z'6AFDB3C4',Z'C6B78776',Z'7483B3FD',Z'13DEFF00',Z'00E0FF00',
Cmw     9Z'0AE704FF',Z'2C3D5E9E',Z'BDCCCBBA',Z'7876FD73',Z'83948575',
Cmw     AZ'6473FF00',Z'6E9BFF00',Z'4E43FDAE',Z'A3FD0BEB',Z'FD06E6FF',
Cmw     BZ'83A4B5B8',Z'A98A6A49',Z'38354463',Z'B3D4E6E9',Z'DBAC4C1B',
Cmw     CZ'09041221',Z'50A0FF00',Z'8C7C6D7E',Z'8E9D9C7A',Z'8CFF09E9',
Cmw     DZ'FD06E6FF',Z'4C3C2D3E',Z'4E5D5C3A',Z'4CFDBCAC',Z'9DAEBECD',
Cmw     EZ'CCAABCFF',Z'202B3D6E',Z'8EBDCBBA',Z'8929FD89',Z'B8C7C6B4',
Cmw     FZ'83633425',Z'FFBE6E63',Z'B3FF4E9E',Z'9343FF00',Z'9E7D6C6A',
Cmw     GZ'59686574',Z'93FF6E8D',Z'9C9AA998',Z'958463FF',Z'1ED3FF00'/
       DATA IZBU2/Z'4B8BBAC9',Z'1406081A',Z'C5B48343',Z'D3C4CBFD',
     1Z'0000FFE3',Z'D4A3030E',Z'ABDAE8E6',Z'BBEAFF0B',Z'06081A4B',
     2Z'E4B34314',Z'4BBBEAFF',Z'1406081A',Z'EEE4B343',Z'0000FFE3',
     3Z'DAE8E707',Z'081A4BAB',Z'C3431406',Z'BDCCFFE4',Z'4C5D7E9E',
     4Z'8838FD40',Z'43D3E4FF',Z'1A080614',Z'FDEADB4B',Z'A0D1E2EB',
     5Z'030EFF40',Z'2A1907FD',Z'D9CA9B5B',Z'00FFE3E7',Z'FD838B4B',
     6Z'7D7E8E8D',Z'8B4BFF8D',Z'41507081',Z'7E8E8DFD',Z'00FF8D7D',
     7Z'05FD030E',Z'E378FDEB',Z'63545EFF',Z'00FF9483',Z'09FD030B',
     8Z'6A4B3B1A',Z'79FD7379',Z'DABBAB8A',Z'00FFE3E9',Z'09FD030B',
     9Z'DAAB4B1A',Z'00FFE3E8',Z'192A5B9B',Z'53241507',Z'E7D5C493',
     AZ'FF9BCAD9',Z'0AFD000B',Z'D9CA9B1B',Z'93C4D5E7',Z'00FF0413',
     BZ'5BABDAE9',Z'1507192A',Z'D4935324',Z'E0EBFDE5',Z'232B0BFF',
     CZ'6B3A29FD',Z'E8E9DAAB',Z'ABDAE9FF',Z'18091A4B',Z'E5D6A747',
     DZ'1443A3D4',Z'0000FF05',Z'9373545E',Z'BB3BFDB4',Z'14060BFF',
     EZ'E5D4A343',Z'FFE3EBFD',Z'FFEB730B',Z'A378430B',Z'E30BFFEB',
     FZ'FFEB03FD',Z'EBFD730B',Z'00FF3051',Z'E303EB0B',Z'000000FF'/
       DATA IZBU3/Z'3C4D6E8E',Z'4435272A',Z'B5A48363',Z'ADBCCAC7',
     1Z'8E3BFF8E',Z'C333FD83',Z'1D0C0BFF',Z'ECDDAE4E',Z'03C9DAEB',
     2Z'0000FFE3',Z'AE4E1D0C',Z'DAEBECDD',Z'A9FD69A9',Z'D4E5E7D8',
     3Z'051443A3',Z'06BEB3FF',Z'0EEEFFE6',Z'AB4B1A09',Z'D4E6E8DA',
     4Z'051443A3',Z'1A3C8EFF',Z'43140608',Z'E7E6D4A3',Z'194AAAD9',
     5Z'0000FF08',Z'33EE0E0C',Z'071849FF',Z'A3431405',Z'D8E7E5D4',
     6Z'0B1A49A9',Z'AE4E1D0C',Z'DAEBECDD',Z'D8E9FFA9',Z'0A1847A7',
     7Z'AE4E1D0B',Z'D7E9EBDD',Z'FF5363B5'/
       DATA IZBU4/Z'194AAAD9',Z'A4441507',Z'737BFDD5',Z'998878FF',
     1Z'78697A8A',Z'948373FD',Z'73647585',Z'E407EAFF',Z'6B8DAEFF',
     2Z'84665859',Z'0000FFA3',Z'07FD737B',Z'BCCBFFE7',Z'2B3C6D8D',
     3Z'C7A8492A',Z'6484B5C6',Z'FD272635',Z'00FF737E',Z'4393B4E7',
     4Z'27161524',Z'ADBCBBAA',Z'3C4D6E8E',Z'FFE44A3B',Z'6E9E8777',
     5Z'8373FD77',Z'64758594',Z'E707FF73',Z'FDCB23FD',Z'00FFC32B',
     6Z'998B6D4E',Z'43648698',Z'998878FF',Z'78697A8A',Z'647383FD',
     7Z'93948575',Z'00FF8371',Z'FFE5E808',Z'6E7D7B6A',Z'3A2B2D3E',
     8Z'C4B3FD6A',Z'7687B7C6',Z'FDB38374',Z'00FFDE13',Z'00FFE000',
     9Z'FF04E70A',Z'9E5E3D2C',Z'BACBCCBD',Z'73FD7678',Z'75859483',
     AZ'00FF7364',Z'00FF9B6E',Z'AEFD434E',Z'EB0BFDA3',Z'FFE606FD',
     BZ'B8B5A483',Z'496A8AA9',Z'63443538',Z'E9E6D4B3',Z'1B4CACDB',
     CZ'21120409',Z'00FFA050',Z'7E6D7C8C',Z'7A9C9D8E',Z'E909FF8C',
     DZ'FFE606FD',Z'3E2D3C4C',Z'3A5C5D4E',Z'ACBCFD4C',Z'CDBEAE9D',
     EZ'FFBCAACC',Z'6E3D2B20',Z'BACBBD8E',Z'89FD2989',Z'B4C6C7B8',
     FZ'25346383',Z'636EBEFF',Z'9E4EFFB3',Z'00FF4393',Z'6A6C7D9E',
     GZ'74656859',Z'8D6EFF93',Z'98A99A9C',Z'FF638495',Z'00FFD31E'/

      SCHRFH=SH
      XINC=SCHRFH*0.05102
      YINC=SCHRFH*0.09091
      XORG=X
      YORG=Y
      ITXPOI=0
   10 ITXPOI=ITXPOI+1
      CALL CHRINT (LTXT,ITXPOI,1, IH)
      IBPOI=IADTAB(IH+1)
      IPENFG=3
   20 IBPOI=IBPOI+1
   30 CALL CHRINT (IZBUF,IBPOI,1, IH)
      IF (IH-254) 50,100,40
   40 XORG=XORG+SCHRFH
      GO TO 100
   50 IF (IH-253) 70,60,60
   60 IPENFG=3
      GO TO 20
   70 IX=IH/16
      IH=IH-16*IX
      PLTKOO(1)=FLOAT(IX)*XINC+XORG
      PLTKOO(2)=FLOAT(IH-3)*YINC+YORG
   80 CALL KPWPLT (PLTKOO,IPENFG)
      IPENFG=2
      GO TO 20
  100 IF (ITXPOI-NLET) 10,999,999
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPPKED
                          SUBROUTINE KPPKED
      DIMENSION ITEMP(2),IAIN(72),IKDOT(10),KDOT(10),VQ(400)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (ITEMP(1),IVON),(ITEMP(2),IBIS)
      EQUIVALENCE (AIN(1),IAIN(1)),(IPK(1),VQ(1))
       DATA IKDOT/4,8,8,8,5,7,11,11,11,11/,IAPO/4H'   /
      DATA KDOT/4HPK  ,4HVB  ,4HVBS ,4HVBR ,4HBA  ,4HBT  ,4HPPFL,
     1   4HVEH ,4HVEU ,4HVE  /
      NTYPS=NTYP
      IPKS=IPKP
      IF (NTYPS-2) 10,20,20
   10 IBIS=999
      IVON=1
      GO TO 30
   20 IBIS=0
      IVON=0
   30 IF (ISKP(14)) 70,40,70
   40 IF (NTYPS-2) 60,50,60
   50 CALL FLES (ITEMP,ISKP(31),2HIE,4HNr?$)
      GO TO 70
   60 CALL FLES (ITEMP,ISKP(31),3H2IE,9Hvon,bis?$)
   70 IF (IBIS) 80,80,90
   80 IBIS=IVON
   90 IF (IVON) 100,100,110
  100 ISKP(10)=360100
      IERR=16
      GO TO 999
  110 IF (IVON-IBIS) 120,120,100
  120 IPKM=0
      I=0
      IPKP=1
      NANZ=0
  130 I=I+1
      IPKP=IPKP+NANZ
      IF (IPKP-IPKS) 140,440,440
  140 NTYP=IPK(IPKP)
      IF (NTYP-6) 150,160,150
  150 NANZ=IKDOT(NTYP)
      GO TO 170
  160 K=IPK(IPKP+6)
      NANZ=7+K
  170 IF (I-IVON) 130,180,180
  180 IF (I-IBIS) 190,190,440
  190 IF (NTYPS-2) 290,220,200
  200 IF (IPKM) 210,210,130
  210 IPKM=IPKP
      GO TO 130
  220 NANQ=NANZ-1
      IF (NTYP-6) 230,250,230
  230 DO 240 J=1,NANQ
      IAIN(J)=IPK(IPKP+J)
  240 CONTINUE
      GO TO 280
  250 DO 260 J=1,5
  260 IAIN(J)=IPK(IPKP+J)
      DO 270 J=1,K
  270 IAIN(J+5)=IPK(IPKP+6+J)
      ISKP(33)=0
      ISKP(34)=K
  280 NTYPSS=NTYP
      NTYPS=4
      GO TO 70
  290 IF (NTYP-5) 300,360,310
  300 IF (NTYP-2) 330,340,340
  310 IF (NTYP-7) 380,400,320
  320 IF (NTYP-10) 420,420,999
  330 WRITE (NTOUT,350) I,KDOT(NTYP),(IPK(IPKP+J),J=1,3)
      GO TO 130
  340 WRITE (NTOUT,350) I,KDOT(NTYP),(IPK(IPKP+J),J=1,4),(VQ(IPKP+J),
     1 J=5,7)
  350 FORMAT (' (',I3,') ',A4,4I4,3F6.2)
      GO TO 130
  360 WRITE (NTOUT,370) I,KDOT(NTYP),IPK(IPKP+1),
     1 (VQ(IPKP+J),J=2,4)
  370 FORMAT (' (',I3,') ',A4,I9,2F6.2,F6.3)
      GO TO 130
  380 WRITE (NTOUT,390) I,KDOT(NTYP),(IPK(IPKP+J),J=1,2),
     1 (VQ(IPKP+J),J=3,5),(IPK(IPKP+J+6),J=1,K),IAPO
  390 FORMAT (' (',I3,') ',A4,2I9,2F6.2,F6.3,' ''',11A4)
      GO TO 130
  400 WRITE (NTOUT,410) I,KDOT(NTYP),(IPK(IPKP+J),J=1,3),
     1 (VQ(IPKP+J),J=4,9),IPK(IPKP+10)
  410 FORMAT (' (',I3,') ',A4,3I9,3F6.1,F5.1,2F5.2,I3)
      GO TO 130
  420 WRITE (NTOUT,430) I,KDOT(NTYP),(IPK(IPKP+J),J=1,4),
     1 (VQ(IPKP+J),J=5,6),(IPK(IPKP+J),J=7,8),(VQ(IPKP+J),J=9,10)
  430 FORMAT (' (',I3,') ',A4,4I4,2F6.2,2I4,2F6.2)
      GO TO 130
  440 IF (NTYPS-2) 490,490,450
  450 IF (IPKM) 490,490,470
  460 IPK(IPKM)=IPK(IPKP)
      IPKM=IPKM+1
      IPKP=IPKP+1
  470 IF (IPKP-IPKS) 460,480,480
  480 IPKP=IPKM
       GO TO 500
  490 IPKP=IPKS
  500 IF (NTYPS-4) 999,510,999
  510 NTYP=NTYPSS
      IF (NTYP-7) 540,530,520
  520 NTYP=NTYP+1
  530 NTYP=NTYP+3
  540 ISKP(14)=-1
      CALL KPLPK
      ISKP(14)=0
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880610--KPPNCD
                          SUBROUTINE KPPNCD
      DIMENSION IAIN(72),INBFR(8),AINBFR(8)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1),IVON),(IAIN(2),IBIS)
      EQUIVALENCE (AIN(3),XOFF),(AIN(4),YOFF)
      EQUIVALENCE (INBFR(1),AINBFR(1))
      DATA KDBLNK/4H    /,AINBFR/.4,.4,6*0./
      DATA IBU0/48/
      NTYPS=NTYP
      K8=0
      NTRY=44
      NC=1
      IF (NTYPS-2) 30,30,10
   10 DO 20 I=3,8
      INBFR(I)=KDBLNK
   20 CONTINUE
      CALL FLES (INBFR,ISKP(31),9H2GAAAAAAE,22H<xoff,yoff,>s1,s2,...$)
      CALL CNVTUP (INBFR,9,24)
      XOFF=AINBFR(1)
      YOFF=AINBFR(2)
      NTYP=NTYPS-2
      GO TO 70
   30 IVON=1
      IBIS=NAT
      XOFF=0.
      YOFF=0.
      CALL FLES (AIN,ISKP(31),5H2I2FE,
     1 19Hfrom,to,xoff,yoff?$)
      IF (IVON) 60,60,40
   40 IF (IBIS-NATDM) 50,50,60
   50 IF (IBIS-IVON) 60,90,90
   60 ISKP(10)=500060
      IERR=16
      GO TO 999
   70 K9=K9+1
      IC=K9
      CALL KPDEK
      DO 80 I=1,3
   80 ATOMS(I,K9)=X2(I)
   90 IF (NCD-K9) 100,100,70
  100 DO 300 IC=NCDA,NCD
      ITEMP=ICD(IC)/100000
      IF (NTYPS-2) 130,130,110
  110 AIN(11)=AT(5,ITEMP)
      CALL CNVTUP (AIN(11),1,4)
      DO 120 I=3,8
      IF (IAIN(11) .EQ. INBFR(I)) GO TO 150
  120 CONTINUE
      GO TO 300
  130 IF (ITEMP-IVON) 300,150,140
  140 IF (ITEMP-IBIS) 150,150,300
  150 NZAHL=IC
      IF (NTYP-1) 160,160,180
  160 NZAHL=ICD(IC)
      NZAHLT=NZAHL/100000
      IF (NZAHL-100000*NZAHLT -55501) 180,170,180
  170 NZAHL=NZAHLT
  180 NSUB=10000000
      IAIN(11)=KDBLNK
      IAIN(12)=KDBLNK
      IFLAG=0
      IPOI=0
  190 I=0
      GO TO 210
  200 I=I+1
  210 NZAHL=NZAHL-NSUB
      IF (NZAHL) 220,200,200
  220 NZAHL=NZAHL+NSUB
      IF (IFLAG) 250,230,250
  230 IF (I) 260,260,240
  240 IFLAG=1
  250 I=I+IBU0
      IPOI=IPOI+1
      CALL INTCHR (I,1,AIN(11),IPOI)
  260 NSUB=NSUB/10
      IF (NSUB) 270,270,190
  270 TEMP=HOE/(HOE-ATOMS(3,IC))
      AIN(7)=(ATOMS(1,IC)*TEMP+XOFF)*O8+CONST(11)
      AIN(8)=(ATOMS(2,IC)*TEMP+YOFF)*O9+CONST(12)
      AIN(9)=CONST(15)*O9*TEMP
      IF (ISKP(26)) 290,280,290
  280 AIN(10)=IPOI
      CALL KPWPLT (AIN(7),11)
      GO TO 300
  290 CALL KPPCHR (AIN(7),AIN(8),AIN(11),IPOI,AIN(9))
  300 CONTINUE
      CALL KPWPLT (AIN,0)
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD870623--KPPPFL
                          SUBROUTINE KPPPFL
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)                                 !AWH12/12/96
      EQUIVALENCE (AIN(4),RAUSL),(AIN(5),W1),(AIN(6),W2),(AIN(7),W3)
      EQUIVALENCE (AIN(8),R1),(AIN(9),R2),(AIN(10),NSTZP)
   10 NTRY=28
      DO 40 NC=1,3
      CDS(NC)=AIN(NC)
      CALL KPDEK
      IF (IERR) 999,20,999
   20 DO 30 J=1,3
   30 X(J,NC)=X2(J)
   40 CONTINUE
      TEMP=0.
      DO 50 I=1,3
      X(I,4)=(X(I,1)+X(I,2))*.5
      TEMB=X(I,1)-X(I,4)
      X(I,1)=TEMB
      TEMP=TEMP+TEMB*TEMB
      X(I,2)=X(I,3)-X(I,4)
   50 CONTINUE
      IF (RAUSL) 70,60,70
   60 RAUSL=SQRT(TEMP)
   70 DO 80 I=1,3
      J=ID2(I)
      K=ID2(J)
      X1(I)=X(J,1)*X(K,2)-X(K,1)*X(J,2)
   80 CONTINUE
      TEMB=0.
      DO 90 I=1,3
      J=ID2(I)
      K=ID2(J)
      TEMP=X1(J)*X(K,1)-X1(K)*X(J,1)
      TEMB=TEMB+TEMP*TEMP
      X(I,2)=TEMP
   90 CONTINUE
      IF (TEMB) 100,100,110
  100 ISKP(10)=280100
      IERR=6
      GO TO 999
  110 TEMB=RAUSL/SQRT(TEMB)
      DO 120 I=1,3
  120 X(I,2)=X(I,2)*TEMB
      A=(W2-W3-W1)/FLOAT(NSTZP-1)
      B=W1-A
      PHI=W1
      ASSIGN 130 TO NRET
      GO TO 150
  130 TEMP=HOE/(HOE-X1(3))
      AIN(15)=X1(1)*TEMP*O8+CONST(11)
      AIN(16)=X1(2)*TEMP*O9+CONST(12)
      AIN(17)=AIN(15)
      AIN(18)=AIN(16)
      TEMP=R1
      II=1
      ASSIGN 230 TO IPLRET
      ASSIGN 170 TO NRET
  140 PHI=A*FLOAT(II)+B
  150 TEMB=PHI*CONST(3)
      COSPHI=COS(TEMB)
      SINPHI=SIN(TEMB)
      ALEN=0.
      DO 160 KK=1,3
      TEMB=X(KK,1)*COSPHI+X(KK,2)*SINPHI
      X2(KK)=TEMB
      X1(KK)=X(KK,4)+TEMB
      ALEN=ALEN+TEMB*TEMB
  160 CONTINUE
      GO TO NRET, (130,170)
  170 IF (ALEN) 180,180,190
  180 ALEN=1.
  190 ALEN2=TEMP/SQRT(ALEN)
      ALEN=1.+ALEN2
      DO 200 KK=1,3
  200 X1(KK)=X(KK,4)+X2(KK)*ALEN
      TEMB=HOE/(HOE-X1(3))
      AIN(11)=X1(1)*TEMB*O8+CONST(11)
      AIN(12)=X1(2)*TEMB*O9+CONST(12)
      ALEN=1.-ALEN2
      DO 210 KK=1,3
  210 X1(KK)=X(KK,4)+X2(KK)*ALEN
      TEMB=HOE/(HOE-X1(3))
      AIN(13)=X1(1)*TEMB*O8+CONST(11)
      AIN(14)=X1(2)*TEMB*O9+CONST(12)
      CALL KPWPLT (AIN(15),3)
      CALL KPWPLT (AIN(11),2)
      CALL KPWPLT (AIN(17),3)
      CALL KPWPLT (AIN(13),2)
      DO 220 J=11,14
  220 AIN(J+4)=AIN(J)
      GO TO IPLRET, (230,250,999)
  230 II=II+1
      IF (II-NSTZP) 140,140,240
  240 ASSIGN 250 TO IPLRET
      TEMP=R2
      GO TO 150
  250 PHI=W2
      TEMP=0.
      ASSIGN 999 TO IPLRET
      GO TO 150
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--KPPRIM
                         SUBROUTINE KPPRIM
      COMMON /KPFCOM/ INTAR(21),TREIBR(4),REALAR(25)
      COMMON /DC2280/ ITIN,NTDSPL,NTPRT,KARTE(60),KARPOI,KAREND
      COMMON /DC2280/ KDSEMI,IVERFY(20)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      COMMON /TFKTRN/ ANTFKT(9,200),NTFKT,NTFDM
      EQUIVALENCE (BLK,IBLK)
      DATA BLK/4H    /,HA,HB/4HUNDE,4HFINI/,HC,HD/4HNULL,4HORGN/
      IF (INTAR(1)) 20,10,20
   10 CONTINUE
      INTAR(1)=ITIN
      INTAR(2)=NTDSPL
      INTAR(3)=NTDSPL
      INTAR(7)=41
      INTAR(12)=1
      INTAR(13)=1
      INTAR(14)=0
      INTAR(15)=1
      INTAR(16)=15
      INTAR(19)=0
      REALAR(8)=6.
      INTAR(20)=1023
      INTAR(21)=779
      TREIBR(3)=45.47
      TREIBR(4)=41.00
      REALAR(2)=22.5
      REALAR(4)=19.
      REALAR(5)=1.5
      REALAR(6)=11.25
      REALAR(7)=9.5
      REALAR(10)=.4
      REALAR(12)=.08
      REALAR(16)=60.
      REALAR(17)=1.
      REALAR(22)=2.7
   20 CONTINUE
      DO 40 I=1,3
      ZELLE(I)=1.
      ZELLE(I+3)=90.
      RK(I)=1.
      UR(I)=0.
      DO 30 J=1,3
      DG(I,J)=0.
      RG(I,J)=0.
      TRA(I,J)=0.
      TRAINV(I,J)=0.
      DREH(I,J)=0.
      GRID(I)=100.
   30 CONTINUE
      DG(I,I)=1.
      RG(I,I)=1.
      TRA(I,I)=1.
      TRAINV(I,I)=1.
      DREH(I,I)=1.
   40 CONTINUE
      HOE=REALAR(16)
      ID2(1)=2
      ID2(2)=3
      ID2(3)=1
      NSYM=0
      NSYMDM=48
      DO 50 I=1,12
   50 SYM(I,1)=0.
      SYM( 2,1)=1.
      SYM( 7,1)=1.
      SYM(12,1)=1.
      NAT=0
      NATDM=200
      NCD=0
      NCDDM=500
      NCDA=1
      K8=0
      K9=0
      O8=REALAR(17)
      O9=REALAR(17)
      IPKP=1
      IPKDM=400
      NTIN=INTAR(1)
      NTOUT=INTAR(2)
      NTPCH=INTAR(3)
      NTSCR=INTAR(4)
      NTXR1=INTAR(5)
      NTXR2=INTAR(6)
      NTBILF=INTAR(7)
      NTDTEI=INTAR(8)
      NTTEMP=INTAR(9)
      DO 60 I=1,40
   60 ISKP(I)=0
      ISKP(1)=INTAR(16)
      ISKP(4)=INTAR(15)
      ISKP(7)=INTAR(12)
      ISKP(8)=10
      ISKP(9)=4
      ISKP(12)=1
      ISKP(13)=INTAR(14)
      ISKP(23)=150
      ISKP(26)=INTAR(13)
      DO 70 I=5,40
   70 CONST(I)=0.
      CONST(1)=3.141593
      CONST(2)=6.283185
      CONST(3)=1.745329E-2
      CONST(4)=57.29578
      CONST(7)=1.E-4
   80 CONTINUE
      CONST(8)=REALAR(2)
      CONST(9)=REALAR(4)
      DO 90 I=1,6
   90 CONST(I+9)=REALAR(I+4)
      CONST(21)=.01
      CONST(23)=REALAR(11)
      CONST(24)=REALAR(12)
      CONST(31)=REALAR(22)
      CONST(32)=100.
      CONST(33)=45.
      CONST(34)=.25
      FKGL=1.
      ISKP(16)=IBLK
      ISKP(17)=IBLK
      ISKP(18)=0
      DO 100 I=1,18
  100 TITEL(I)=BLK
      DO 110 I=1,NATDM
      AT(5,I)=HA
      AT(6,I)=HB
  110 AT(4,I)=.3
      AT(4,1)=.01
      AT (5,1)=HD
      AT(6,1)=BLK
      AT(4,2)=.01
      AT(5,2)=HC
      AT(6,2)=BLK
      DO 120 I=1,3
      AT(I,1)=.5
  120 AT(I,2)=0.
      NTFDM=200
      NTFKT=0
      NPLST(1)=0
      NPLST(2)=100
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPSRT
                          SUBROUTINE KPSRT
      DIMENSION ISTK(3,100),JAT(6,200),JATS(6)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IT1),(AIN(2),IT2),(AIN(3),IT3),(AIN(4),K)
      EQUIVALENCE (AIN(5),IA),(AIN(6),IE),(AIN(7),H),(AIN(8),ITM)
      EQUIVALENCE (AIN(9),ITN),(AIN(10),I),(AIN(11),J),(AIN(12),JATS(1))
      EQUIVALENCE (ISTK(1,1),ATOMS(1,1)),(AT(1,1),JAT(1,1))
      DATA JELEMH/4HH   /
      GO TO (10,10,310,380,510,510),NTYP
   10 IF (ISKP(14)) 30,20,30
   20 CALL FLES (AIN,ISKP(31),2HIE,20HKoordinate (1/2/3)?$)
   30 IF (IT1) 50,50,40
   40 IF (IT1-3) 60,60,50
   50 ISKP(10)=240050
      IERR=16
      GO TO 999
   60 IF (NCD-NCDA) 70,80,80
   70 ISKP(10)=240070
      IERR=12
      GO TO 999
   80 IT2=ID2(IT1)
      IT3=ID2(IT2)
      NC=1
      IF (NTYP-2) 90,120,310
   90 K9=0
      NTRY=40
  100 IF (K8-NCD) 110,150,150
  110 K8=K8+1
      IC=K8
      CALL KPDEK
      ATOMS(IT1,K8)=X(IT1,1)
      GO TO 100
  120 K8=0
      NTRY=44
  130 IF (K9-NCD) 140,150,150
  140 K9=K9+1
      IC=K9
      CALL KPDEK
      ATOMS(IT1,K9)=X2(IT1)
      GO TO 130
  150 K=0
      IA=NCDA
      IE=NCD
  160 I=IA
      J=IE
      H=ATOMS(IT1,I)
      ITM=ICD(I)
  170 IF (H-ATOMS(IT1,J)) 220,220,180
  180 ATOMS(IT1,I)=ATOMS(IT1,J)
      ATOMS(IT1,J)=H
      ICD(I)=ICD(J)
      ICD(J)=ITM
  190 I=I+1
      IF (I-J) 200,230,230
  200 IF (ATOMS(IT1,I)-H) 190,190,210
  210 ATOMS(IT1,J)=ATOMS(IT1,I)
      ATOMS(IT1,I)=H
      ICD(J)=ICD(I)
      ICD(I)=ITM
  220 J=J-1
      IF (I-J) 170,230,230
  230 I=I-1
      J=J+1
      IF (I-IA) 240,240,270
  240 IA=J
      IF (J-IE) 160,250,250
  250 IF (K) 300,300,260
  260 IA=ISTK(IT2,K)
      IE=ISTK(IT3,K)
      K=K-1
      GO TO 160
  270 IF (J-IE) 280,290,290
  280 K=K+1
      ISTK(IT2,K)=J
      ISTK(IT3,K)=IE
  290 IE=I
      GO TO 160
  300 K8=0
      K9=0
      GO TO 999
  310 CALL FLES (AIN,ISKP(31),1HE,2H?$)
      I=NCDA
  320 IF (I-NCD) 330,300,300
  330 I=I+1
      J=I
      JP1=J
      IT1=ICD(J)
      GO TO 350
  340 ICD(JP1)=ICD(J)
      JP1=JP1-1
  350 J=J-1
      IF (J-NCDA) 370,360,360
  360 IF (IT1-ICD(J)) 340,370,370
  370 ICD(JP1)=IT1
      GO TO 320
  380 CALL FLES (AIN,ISKP(31),3H3IE,10HN1,N2,M1?$)
      IF (ISKP(31)-2) 440,390,400
  390 IT3=IT2+1
  400 IF (IT1-IT2) 410,410,440
  410 IF (IT1) 440,440,420
  420 IF (IT2-NATDM) 430,430,440
  430 IF (IT3) 440,440,450
  440 ISKP(10)=240440
      IERR=16
      GO TO 999
  450 K=IT3+IT2-IT1
      IF (K-NATDM) 460,460,440
  460 DO 500 I=IT1,IT2
      TEMP2=999.
      DO 480 J=IT3,K
      TEMP=ABS(AT(1,I)-AT(1,J))+ABS(AT(2,I)-AT(2,J))+ABS(AT(3,I)-AT(3,J)
     1)
      IF (TEMP2-TEMP) 480,480,470
  470 MERK=J
      TEMP2=TEMP
  480 CONTINUE
      DO 490 J=1,6
      TEMP=AT(J,IT3)
      AT(J,IT3)=AT(J,MERK)
  490 AT(J,MERK)=TEMP
      IT3=IT3+1
  500 CONTINUE
      GO TO 999
  510 IF (ISKP(14)) 530,520,530
  520 IT1=1
      IT2=NAT
      CALL FLES (AIN,ISKP(31),3H2IE,9Hvon,bis?$)
  530 IF (IT1) 560,560,540
  540 IF (IT2-NATDM) 550,550,560
  550 IF (IT1-IT2) 570,999,560
  560 ISKP(10)=240560
      IERR=16
      GO TO 999
  570 I=IT1
  580 J=I
      I=I+1
      IF (NTYP-6) 600,590,600
  590 IF (JAT(5,I)-JELEMH) 600,710,600
  600 DO 610 K=1,6
  610 JATS(K)=JAT(K,I)
      GO TO 640
  620 DO 630 K=1,6
  630 JAT(K,J+1)=JAT(K,J)
      J=J-1
      IF (J-IT1) 690,640,640
  640 IF (NTYP-6) 660,650,999
  650 IF (JAT(5,J)-JELEMH) 680,620,680
  660 IF (JATS(5)-JAT(5,J)) 620,670,680
  670 IF (JATS(6)-JAT(6,J)) 620,680,680
  680 IF (J+1-I) 690,710,690
  690 DO 700 K=1,6
  700 JAT(K,J+1)=JATS(K)
  710 IF (I-IT2) 580,300,300
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPSYDC
                          SUBROUTINE KPSYDC
      DIMENSION IBUF(12),ITAB( 6),ITRANS(11),IFLG(4),IAIN(72)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (AIN(1),IAIN(1))
      DATA ITAB/4H0123,4H4567,4H89,+,4H- ./,4HXYZx,4Hyz  /
      DATA ITRANS/112,16,14,13,512,12,712,23,34,56,1112/
      IF (ISKP(14) .NE. 0) GO TO 10
      CALL FLES (IAIN,ISKP(31),4H18AE,11HSymmetrie?$)
   10 LENG=ISKP(31)*4+1
      IF (NSYM .LT. NSYMDM) GO TO 20
      IERR=3
      ISKP(10)=210010
      GO TO 999
   20 DO 30 I=1,12
   30 IBUF(I)=0
      NSYM=NSYM+1
      CALL COPYCH (ITAB,14,1, IH,1)
      IRC=0
      LINC=0
      IWDH=0
      LPOI=0
   40 DO 50 I=1,4
   50 IFLG(I)=0
   60 ITYP=0
      IVORZ=0
      IZFF=0
      KBUF=0
      IPKT=0
   70 IF (IWDH .EQ. 0) GO TO 80
      IWDH=0
      GO TO 110
   80 LPOI=LPOI+1
      IF (LPOI-LENG) 90,120,300
   90 CALL COPYCH (IAIN,LPOI,1, IH,1)
      DO 100 IZCH=1,22
      IF (LCOMPS(IH,1,1, ITAB,IZCH) .EQ. 0) GO TO 110
  100 CONTINUE
      IRC=5
      GO TO 310
  110 IF (IZCH .GT. 10) GO TO 130
      IF (IVORZ .EQ. 0) IVORZ=1
      IZFF=1
      KBUF=KBUF*10+IZCH-1
      IPKT=IPKT*10
      GO TO 70
  120 IZCH=11
  130 IGO=IZCH-10
      GO TO (140,240,240,70,330,260,280,280,280,270,270,270),IGO
  140 IF (ITYP .NE. 0) GO TO 170
      IF (IVORZ .EQ. 0) GO TO 160
  150 IRC=1
      GO TO 310
  160 IF (IFLG(2)+IFLG(3)+IFLG(4) .LE. 0) GO TO 150
      LINC=LINC+4
      IF (LINC .LE. 8) GO TO 40
      GO TO 310
  170 IF (IFLG(1) .EQ. 0) GO TO 190
  180 IRC=6
      GO TO 310
  190 IFLG(1)=1
      IF (IVORZ .GT. 0) GO TO 200
      IRC=7
      GO TO 310
  200 IWDH=1
      IF (ITYP .GT. 0) GO TO 210
      ITYP=1
      I=(KBUF*12+IPKT/2)/IPKT
      GO TO 230
  210 DO 220 I=1,11
      IF (KBUF .EQ. ITRANS(I)) GO TO 230
  220 CONTINUE
      IRC=3
      GO TO 310
  230 IBUF(LINC+1)=I
      GO TO 60
  240 IF (IVORZ .EQ. 0) GO TO 250
      IF (ITYP .NE. 0) GO TO 170
      IRC=8
  250 IVORZ=1
      IF (IGO .EQ. 3) IVORZ=-1
      GO TO 70
  260 ITYP=1
      GO TO 70
  270 IGO=IGO-3
  280 IF (ITYP .NE. 0) GO TO 170
      ITYP=IGO-5
      IF (IFLG(ITYP) .NE. 0) GO TO 180
      IFLG(ITYP)=1
      IF (IVORZ .EQ. 0) IVORZ=1
      IF (IZFF .LE. 0) KBUF=1
      IBUF(LINC+ITYP)=KBUF*IVORZ
      GO TO 60
  300 IRC=9
  310 IF (IRC .LE. 0) GO TO 340
      IF (ISKP(4) .EQ. 0) CALL FLES (AIN,AIN,1HK,AIN)
      WRITE (NTOUT,320) IRC
  320 FORMAT (' KPSYDC0320 - Symmetrie fehlerhaft. Code:',I2)
      NSYM=NSYM-1
      GO TO 999
  330 IPKT=1
      ITYP=-1
      IF (IVORZ .EQ. 0) IVORZ=1
      GO TO 70
  340 DO 350 I=1,12
  350 SYM(I,NSYM)=FLOAT(IBUF(I))
      SYM(1,NSYM)=SYM(1,NSYM)/12.
      SYM(5,NSYM)=SYM(5,NSYM)/12.
      SYM(9,NSYM)=SYM(9,NSYM)/12.
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD870623--KPSYOU
                          SUBROUTINE KPSYOU
      INTEGER*4 ITPOI(12),ITTAB(10),IZTAB(4),DB2210
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)                                 !AWH12/12/96
      DATA ITPOI/1,5,8,11,14,18,21,25,28,31,34,39/
      DATA ITTAB/4H1/12,4H1/61,4H/41/,4H35/1,4H21/2,4H7/12,4H2/33,
     1 4H/45/,4H611/,4H12  /
      DATA IZTAB/4H0123,4H4567,4H89+-,4H,   /,IXTAB/4HXYZ /
       DATA TOL/0.0083/,BLANK/4H    /,IAPO/4H'   /
      ISYNR=DB2210(0)
      WRITE (NTOUT,10) ISKP(18),ISKP(16),ISKP(17)
   10 FORMAT ('0Symmetrien (Rg Nr',I6,2X,2A4,1H))
      DO 350 M=1,NSYM
      IOPOI=0
      DO 20 I=1,10
   20 AIN(I)=BLANK
      DO 250 I0=1,9,4
      I1=0
      TEMP=SYM(I0,M)*12.
      I2=TEMP+TOL
      IF (ABS(FLOAT(I2)-TEMP)-TOL) 40,30,30
   30 IRC=1
      GO TO 330
   40 IF (I2) 30,80,50
   50 IF (I2-12) 60,30,30
   60 J1=ITPOI(I2)
      J2=ITPOI(I2+1)-1
      DO 70 I=J1,J2
      IOPOI=IOPOI+1
      CALL COPYCH (ITTAB,I,1, AIN,IOPOI)
   70 CONTINUE
      I1=1
   80 SYM(I0,M)=FLOAT(I2)/12.
      DO 210 J0=1,3
      TEMP=SYM(I0+J0,M)
      I2=ABS(TEMP)+TOL
      IF (TEMP) 90,210,100
   90 I2=-I2
  100 IF (ABS(FLOAT(I2)-TEMP)-TOL) 120,110,110
  110 IRC=3
      GO TO 330
  120 SYM(I0+J0,M)=I2
      IF (I2) 150,210,130
  130 IF (I1) 140,160,140
  140 IOPOI=IOPOI+1
      CALL COPYCH (IZTAB,11,1, AIN,IOPOI)
      GO TO 160
  150 IOPOI=IOPOI+1
      CALL COPYCH (IZTAB,12,1, AIN,IOPOI)
      I2=-I2
  160 I1=1
      IF (I2-9) 180,180,170
  170 IRC=2
      GO TO 330
  180 IF (I2-1) 170,200,190
  190 IOPOI=IOPOI+1
      CALL COPYCH (IZTAB,I2+1,1, AIN,IOPOI)
  200 IOPOI=IOPOI+1
      CALL COPYCH (IXTAB,J0,1, AIN,IOPOI)
  210 CONTINUE
      IF (I1) 230,220,230
  220 IOPOI=IOPOI+1
      CALL COPYCH (IZTAB,1,1, AIN,IOPOI)
  230 IF (I0-5) 240,240,250
  240 IOPOI=IOPOI+2
      CALL COPYCH (IZTAB,13,2, AIN,IOPOI-1)
  250 CONTINUE
      IF (ISKP(14)) 260,300,280
  260 WRITE (NTXR1,270) (AIN(I),I=1,10)
  270 FORMAT ('SYMTRY  ',10A4)
      GO TO 320
  280 CALL COPYCH (IAPO,1,1, AIN,IOPOI+1)
      WRITE (NTBILF,290) (AIN(I),I=1,10)
  290 FORMAT ('SY ''',10A4)
      GO TO 320
  300 IOPOI=(IOPOI+3)/4
      WRITE (NTOUT,310) M,(AIN(I),I=1,IOPOI)
  310 FORMAT (' ',I6,')  ',10A4)
  320 IF (ISKP(20)) 999,325,999
  325 IF (DB2210(1)) 999,350,999
  330 WRITE (NTOUT,340) (SYM(I,M),I=1,12),IRC
  340 FORMAT (1H ,12F5.2,' Fehler',I2)
  350 CONTINUE
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPTFHN
                          SUBROUTINE KPTFHN
      DIMENSION INBUF(2)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      COMMON /TFKTRN/ ANTFKT(9,200),NTFKT,NTFDM
      DATA BLANK/4H    /,ALLE/4HALLE/
      IF (NTYP-2) 10,150,230
   10 DO 20 I=3,9
   20 AIN(I)=0.
      CALL FLES (AIN,ISKP(31),3HAAR,13HSymb.,Untr.?$)
      IF (ISKP(31)) 30,30,40
   30 ISKP(10)=550030
      IERR=16
      GO TO 999
   40 I=0
      GO TO 80
   50 IF (ANTFKT(1,I) .NE. AIN(1)) GO TO 80
      IF (ANTFKT(2,I) .NE. AIN(2)) GO TO 80
   60 DO 70 J=3,9
   70 AIN(J)=ANTFKT(J,I)
      GO TO 130
   80 I=I+1
      IF (I-NTFKT) 50,50,90
   90 IF (NTFKT-NTFDM) 120,100,100
  100 CALL FLES (AIN,AIN,1HK,AIN)
      WRITE (NTOUT,110) AIN(1),AIN(2)
  110 FORMAT (' KPTFHN0090 - T.F. fuer ',2A4,' nicht mehr speicherbar.')
      GO TO 999
  120 NTFKT=NTFKT+1
  130 CALL FLES (AIN(3),ISKP(31),3H7FE,29Hu11,u22,u33,u12,u13,u23,Typ?$)
      DO 140 J=1,9
  140 ANTFKT(J,I)=AIN(J)
      GO TO 999
  150 AIN(1)=BLANK
      AIN(2)=BLANK
      CALL FLES (AIN,ISKP(31),3HAAE,13HSymb.,Untr.?$)
      IF (AIN(1) .NE. ALLE) GO TO 160
      NTFKT=0
      GO TO 999
  160 K=0
      IF (AIN(2) .NE. BLANK) K=1
      I=0
      J=0
      GO TO 210
  170 IF (ANTFKT(1,J) .NE. AIN(1)) GO TO 190
      IF (K) 180,210,180
  180 IF (ANTFKT(2,J) .EQ. AIN(2)) GO TO 210
  190 I=I+1
      DO 200 L=1,9
  200 ANTFKT(L,I)=ANTFKT(L,J)
  210 J=J+1
      IF (J-NTFKT) 170,170,220
  220 NTFKT=I
      GO TO 999
  230 INBUF(1)=1
      INBUF(2)=NTFKT
      CALL FLES (INBUF,ISKP(31),3H2IE,9Hvon,bis?$)
      IF (NTFKT) 240,240,250
  240 ISKP(10)=550240
      IERR=19
      GO TO 999
  250 IF (INBUF(1)) 280,280,260
  260 IF (INBUF(2)-NTFKT) 270,270,265
  265 INBUF(2)=NTFKT
  270 IF (INBUF(1)-INBUF(2)) 290,290,280
  280 ISKP(10)=550280
      IERR=16
      GO TO 999
  290 WRITE (NTOUT,300)
  300 FORMAT (' Nr   Name      U11      U22      U33      U12      U13
     1    U23    Typ')
      I=INBUF(1)
      GO TO 330
  310 WRITE (NTOUT,320) I,(ANTFKT(J,I),J=1,9)
  320 FORMAT (' ',I3,' ',2A4,6F9.6,F4.0)
      I=I+1
  330 IF (I-INBUF(2)) 310,310,999
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD870623--KPVBU
                           SUBROUTINE KPVBU
      DIMENSION VAT(5,3),V(2),VS(2),VSO(2),VSU(2),PO(2),PU(2)
      DIMENSION CTAB( 8),STAB( 8),SCTAB(16),TBUF(2),TBUF10(2),TBUF01(2)
      DIMENSION TBU0M1(2)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)                                 !AWH12/12/96
      EQUIVALENCE (X(1,1),VAT(1,1)),(X(1,6),V(1)),(X(3,6),VS(1))
      EQUIVALENCE (X(2,7),VSO(1)),(S(1,1),VSU(1)),(S(3,1),DFLAE)
      EQUIVALENCE (S(1,2),DRAEU),(S(2,2),COSD),(S(3,2),SIND)
      EQUIVALENCE (S(1,3),U1),(S(2,3),U2),(S(3,3),U)
      EQUIVALENCE (CDS(1),PO(1)),(CDS(3),PU(1))
      DATA NSTZP/0/,TBUF10/1.,0./,TBUF01/0.,1./,TBU0M1/0.,-1./
      DATA SCTAB/0.,.5,.8660254,1.,.8660254,.5,0.,-.5,-.8660254,-1.,
     1 -.8660254,-.5,0.,.5,.8660254,1./
      IF (NSTZP-ISKP(9)) 10,30,10
   10 NSTZP=ISKP(9)
      TEMP2=CONST(1)/FLOAT(NSTZP-1)
      DO 20 I=1,NSTZP
      TEMP=FLOAT(I-1)*TEMP2
      CTAB(I)=COS(TEMP)
      STAB(I)=SIN(TEMP)
   20 CONTINUE
   30 IF (VAT(3,1)-ATOMS(3,IC)) 50,40,40
   40 I=2
      J=3
      GO TO 60
   50 I=3
      J=2
   60 DO 70 K=1,5
   70 VAT(K,I)=VAT(K,1)
      TEMP=HOE/(HOE-ATOMS(3,IC))
      VAT(1,J)=TEMP*ATOMS(1,IC)
      VAT(2,J)=TEMP*ATOMS(2,IC)
      VAT(3,J)=ATOMS(3,IC)
      VAT(4,J)=TEMP*AT(4,IZ2)*FKGL
      VAT(5,J)=TEMP*T(3)
      AIN(1)=VAT(1,2)*O8+CONST(11)
      AIN(2)=VAT(2,2)*O9+CONST(12)
      AIN(3)=VAT(1,3)*O8+CONST(11)
      AIN(4)=VAT(2,3)*O9+CONST(12)
      AIN(5)=AIN(3)-AIN(1)
      AIN(6)=AIN(4)-AIN(2)
      TEMP=AIN(5)*AIN(5)+AIN(6)*AIN(6)
      IF (TEMP) 999,999,80
   80 TEMP=T(2)/SQRT(TEMP)
      EXT2=(AIN(5)-AIN(6))*TEMP
      EXT1=(AIN(5)+AIN(6))*TEMP
      IF (NTYP-2) 999,90,100
   90 CALL KPWPLT (AIN(1),3)
      CALL KPWPLT (AIN(3),2)
      GO TO 999
  100 DFLAE=(VAT(1,3)-VAT(1,2))**2+(VAT(2,3)-VAT(2,2))**2
      IF (DFLAE) 110,110,140
  110 IF (ISKP(6)) 120,999,120
  120 WRITE (NTOUT,130)
  130 FORMAT (' KPVBU0130 - Bindung verdeckt.')
      GO TO 999
  140 DRAEU=SQRT(DFLAE+(VAT(3,3)-VAT(3,2))**2)
      DFLAE=SQRT(DFLAE)
      COSD=DFLAE/DRAEU
      U=(DRAEU-VAT(4,3))*COSD
      IF (U-VAT(4,2)) 110,110,150
  150 DO 160 I=1,2
  160 V(I)=(VAT(I,3)-VAT(I,2))/DFLAE
      IF (NTYP-3) 999,170,190
  170 AIN(1)=(VAT(1,2)+VAT(4,2)*V(1))*O8+CONST(11)
      AIN(2)=(VAT(2,2)+VAT(4,2)*V(2))*O9+CONST(12)
      AIN(3)=(VAT(1,2)+U*V(1))*O8+CONST(11)
      AIN(4)=(VAT(2,2)+U*V(2))*O9+CONST(12)
      CALL KPWPLT (AIN(1),3)
      CALL KPWPLT (AIN(3),2)
  180 AIN(7)=AIN(1)
      AIN(8)=AIN(2)
      AIN(5)=AIN(3)
      AIN(6)=AIN(4)
      GO TO 270
  190 SIND=(VAT(3,2)-VAT(3,3))/DRAEU
      VAT(5,2)=VAT(5,2)*(1.+.3*SIND)
      VAT(5,3)=VAT(5,3)*(1.-.3*SIND)
      VS(1)=V(2)
      VS(2)=-V(1)
      DO 200 I=1,2
      VSO(I)=VS(I)*VAT(5,2)
      VSU(I)=VS(I)*VAT(5,3)
      VS(I)=SIND*VAT(5,3)*V(I)
  200 CONTINUE
      U1=VAT(4,2)**2-VAT(5,2)**2
      IF (U1) 210,210,220
  210 ISKP(10)=190210
      IERR=13
      GO TO 999
  220 U1=SQRT(U1)
      U2=VAT(4,3)**2-VAT(5,3)**2
      IF (U2) 210,210,230
  230 U2=(DRAEU-SQRT(U2))*COSD
      DO 240 I=1,2
      PO(I)=VAT(I,2)+U1*V(I)
  240 PU(I)=VAT(I,2)+U2*V(I)
      J=1
      AIN(J)=  (PO(1)+VSO(1))*O8+CONST(11)
      AIN(J+1)=(PO(2)+VSO(2))*O9+CONST(12)
      CALL KPWPLT (AIN(J),3)
      J=J+2
      DO 260 I=1,NSTZP
      AIN(J)=  (PU(1)+VSU(1)*CTAB(I)+VS(1)*STAB(I))*O8+CONST(11)
      AIN(J+1)=(PU(2)+VSU(2)*CTAB(I)+VS(2)*STAB(I))*O9+CONST(12)
      CALL KPWPLT (AIN(J),2)
      IF (I-1) 260,250,260
  250 J=J+2
  260 CONTINUE
      J=J+2
      AIN(J)=  (PO(1)-VSO(1))*O8+CONST(11)
      AIN(J+1)=(PO(2)-VSO(2))*O9+CONST(12)
      CALL KPWPLT (AIN(J),2)
  270 IF (ISKP(25)) 280,999,280
  280 CALL KPWPLT (TBUF01,17)
      TBUF(1)=AIN(7)-EXT1
      TBUF(2)=AIN(8)+EXT2
      CALL KPWPLT (TBUF,3)
      TBUF(1)=AIN(1)-EXT2
      TBUF(2)=AIN(2)-EXT1
      CALL KPWPLT (TBUF,2)
      TBUF(1)=AIN(3)+EXT1
      TBUF(2)=AIN(4)-EXT2
      CALL KPWPLT (TBUF,2)
      TBUF(1)=AIN(5)+EXT2
      TBUF(2)=AIN(6)+EXT1
      CALL KPWPLT (TBUF,2)
      TBUF(1)=AIN(7)-EXT1
      TBUF(2)=AIN(8)+EXT2
      CALL KPWPLT (TBUF,2)
      IF (NTYP-4) 320,290,320
  290 IF (ISKP(27)) 300,320,300
  300 CALL KPWPLT (TBU0M1,17)
      PLTRD=VAT(4,3)+(CONST(26)*VAT(3,3)+CONST(25))/O8
      J=3
      DO 310 I=1,13
      AIN(11)=(VAT(1,3)+PLTRD*SCTAB(I+3))*O8+CONST(11)
      AIN(12)=(VAT(2,3)+PLTRD*SCTAB(I))*O9+CONST(12)
      CALL KPWPLT (AIN(11),J)
      J=2
  310 CONTINUE
      CALL KPWPLT (TBUF,16)
      CALL KPWPLT (TBUF01,17)
      CALL KPWPLT (AIN(7),3)
      CALL KPWPLT (AIN(1),2)
      CALL KPWPLT (AIN(3),2)
      CALL KPWPLT (AIN(5),2)
      CALL KPWPLT (AIN(7),2)
  320 CALL KPWPLT (TBUF,16)
      CALL KPWPLT (TBUF10,17)
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD870622--KPVLEK
                    SUBROUTINE KPVLEK (IPLTBF)
      DIMENSION IAIN(72),TBUF(2),PLTKOO(4),KNTBFR(1500)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)                                 !AWH12/12/96
      EQUIVALENCE (AIN(1),IAIN(1)),(TEMP,ITEMP),(ATOMS(1,1),KNTBFR(1))
      EQUIVALENCE (PLTKOO(1),XK1),(PLTKOO(2),YK1)
      EQUIVALENCE (PLTKOO(3),XK2),(PLTKOO(4),YK2)
      DATA TBUF /1.,0./
      NTYPS=IPK(IPLTBF)
      IF (NCD-NCDA) 999,999,10
   10 IAIN1=IPK(IPLTBF+1)*100000
      IAIN2=IPK(IPLTBF+2)*100000+99999
      IAIN3=IPK(IPLTBF+3)*100000
      IAIN4=IPK(IPLTBF+4)*100000+99999
      ITEMP=IPK(IPLTBF+5)
      D5Q=TEMP*TEMP
      ITEMP=IPK(IPLTBF+6)
      D6Q=TEMP*TEMP
      ITEMP=IPK(IPLTBF+9)
      D9Q=TEMP*TEMP
      ITEMP=IPK(IPLTBF+10)
      D10Q=TEMP*TEMP
   20 ISPSTR=3*NCD
      ISPPOI=ISPSTR
      NZPKT=0
      TBUF(2)=1.
      IF (NTYPS-10) 40,30,40
   30 TBUF(2)=0.
      NTYPS=8
   40 IF (ISKP(25)) 50,60,50
   50 CALL KPWPLT (TBUF,17)
   60 N1=NCD
   70 N2=N1
      IAN1=ICD(N1)
      ITYP=0
      IF (IAN1-IAIN1) 100,80,80
   80 IF (IAN1-IAIN2) 90,90,100
   90 ITYP=1
  100 IF (IAN1-IAIN3) 130,110,110
  110 IF (IAN1-IAIN4) 120,120,130
  120 ITYP=ITYP+2
  130 IF (ITYP) 510,510,140
  140 TEMP=ATOMS(1,IC)-ATOMS(1,N1)
      TEMP2=TEMP*TEMP
      IF (TEMP2-D10Q) 150,150,510
  150 TEMP=ATOMS(2,IC)-ATOMS(2,N1)
      TEMP2=TEMP*TEMP+TEMP2
      IF (TEMP2-D10Q) 160,160,510
  160 TEMP=ATOMS(3,IC)-ATOMS(3,N1)
      TEMP2=TEMP*TEMP+TEMP2
      IF (TEMP2-D10Q) 170,170,510
  170 IF (TEMP2-D9Q) 510,180,180
  180 IF (NTYPS-9) 190,500,190
  190 TEMP=HOE/(HOE-ATOMS(3,N1))
      XK1=ATOMS(1,N1)*TEMP*O8+CONST(11)
      YK1=ATOMS(2,N1)*TEMP*O8+CONST(12)
      GO TO 500
  200 IAN2=ICD(N2)
      IF (ITYP-2) 240,210,210
  210 IF (IAN2-IAIN1) 230,220,220
  220 IF (IAN2-IAIN2) 260,260,230
  230 IF (ITYP-2) 500,500,240
  240 IF (IAN2-IAIN3) 500,250,250
  250 IF (IAN2-IAIN4) 260,260,500
  260 TEMP=ATOMS(1,IC)-ATOMS(1,N2)
      TEMP2=TEMP*TEMP
      IF (TEMP2-D10Q) 270,270,500
  270 TEMP=ATOMS(2,IC)-ATOMS(2,N2)
      TEMP2=TEMP*TEMP+TEMP2
      IF (TEMP2-D10Q) 280,280,500
  280 TEMP=ATOMS(3,IC)-ATOMS(3,N2)
      TEMP2=TEMP*TEMP+TEMP2
      IF (TEMP2-D10Q) 290,290,500
  290 IF (TEMP2-D9Q) 500,300,300
  300 TEMP=ATOMS(1,N2)-ATOMS(1,N1)
      TEMP2=TEMP*TEMP
      IF (TEMP2-D6Q) 310,310,500
  310 TEMP=ATOMS(2,N2)-ATOMS(2,N1)
      TEMP2=TEMP*TEMP+TEMP2
      IF (TEMP2-D6Q) 320,320,500
  320 TEMP=ATOMS(3,N2)-ATOMS(3,N1)
      TEMP2=TEMP*TEMP+TEMP2
      IF (TEMP2-D6Q) 330,330,500
  330 IF (TEMP2-D5Q) 500,340,340
  340 IF (NTYPS-9) 350,360,350
  350 TEMP=HOE/(HOE-ATOMS(3,N2))
      XK2=ATOMS(1,N2)*TEMP*O8+CONST(11)
      YK2=ATOMS(2,N2)*TEMP*O8+CONST(12)
      CALL KPWPLT (PLTKOO(1),3)
      CALL KPWPLT (PLTKOO(3),2)
      GO TO 500
  360 IF (ISPPOI-1498) 390,390,370
  370 WRITE (NTOUT,380)
  380 FORMAT (' KPVLEK0380 - Polyeder hat zu viele Punkte.')
      NTYPS=8
      GO TO 20
  390 ISPPOI=ISPPOI+2
      KNTBFR(ISPPOI-1)=N1
      KNTBFR(ISPPOI)=N2
      IF (NZPKT-70) 400,400,370
  400 J=3
      IF (NZPKT) 460,460,410
  410 DO 450 I=1,NZPKT
      IF (IAIN(I)-N2) 430,420,430
  420 J=J-1
  430 IF (IAIN(I)-N1) 450,440,450
  440 J=J-2
  450 CONTINUE
  460 IF (J-2) 480,470,470
  470 J=J-2
      NZPKT=NZPKT+1
      IAIN(NZPKT)=N1
  480 IF (J) 500,500,490
  490 NZPKT=NZPKT+1
      IAIN(NZPKT)=N2
  500 N2=N2-1
      IF (N2-NCDA) 510,200,200
  510 N1=N1-1
      IF (N1-NCDA) 520,520,70
  520 IF (NTYPS-9) 990,530,990
  530 I1=ISPSTR
      IF (ISPPOI-ISPSTR-6) 999,830,830
  540 IF (KNTBFR(I1)) 550,560,560
  550 IF (KNTBFR(I2)) 820,560,560
  560 J1=KNTBFR(I1-1)
      J2=IABS(KNTBFR(I1))
      J3=KNTBFR(I2-1)
      J4=IABS(KNTBFR(I2))
  570 IF (J1-J3) 580,610,580
  580 IF (J1-J4) 590,620,590
  590 IF (J2-J3) 600,610,600
  600 IF (J2-J4) 820,620,820
  610 J3=J4
  620 DO 630 I=1,3
      X1(I)=ATOMS(I,J2)-ATOMS(I,J1)
      X2(I)=ATOMS(I,J3)-ATOMS(I,J1)
  630 CONTINUE
      D=0.
      D1=0.
      DO 640 I=1,3
      J=ID2(I)
      K=ID2(J)
      TEMP=X1(J)*X2(K)-X1(K)*X2(J)
      T(I)=TEMP
      D=D-TEMP*ATOMS(I,J1)
      D1=D1+ABS(TEMP)
  640 CONTINUE
      IF (D1) 650,650,670
  650 WRITE (NTOUT,660) J1,J2,J3
  660 FORMAT (' KPVLEK0762 - Punkte',3I4,' bilden keine Ebene.')
      GO TO 999
  670 IF (T(1)*ATOMS(1,IC)+T(2)*ATOMS(2,IC)
     &                              +T(3)*ATOMS(3,IC)+D) 680,700,700
  680 DO 690 I=1,3
  690 T(I)=-T(I)
      D=-D
  700 IF (HOE*T(3)+D) 710,820,820
  710 DO 750 I=1,NZPKT
      J=IAIN(I)
      IF (J-J1) 720,750,720
  720 IF (J-J2) 730,750,730
  730 IF (J-J3) 740,750,740
  740 IF (T(1)*ATOMS(1,J)+T(2)*ATOMS(2,J)+T(3)*ATOMS(3,J)+D) 820,820,750
  750 CONTINUE
      J=I1
  760 K=3
      N2=KNTBFR(J)
      IF (N2) 800,800,770
  770 N1=KNTBFR(J-1)
      KNTBFR(J)=-N2
  780 TEMP=HOE/(HOE-ATOMS(3,N1))
      XK1=ATOMS(1,N1)*TEMP*O8+CONST(11)
      YK1=ATOMS(2,N1)*TEMP*O8+CONST(12)
      CALL KPWPLT (PLTKOO,K)
      IF (K-2) 790,800,790
  790 K=2
      N1=N2
      GO TO 780
  800 IF (J-I2) 810,820,810
  810 J=I2
      GO TO 760
  820 I2=I2+2
      IF (I2-ISPPOI) 540,540,830
  830 I1=I1+2
      I2=I1
      IF (I1+2-ISPPOI) 820,820,990
  990 IF (ISKP(25)) 995,999,995
  995 CALL KPWPLT (TBUF,16)
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD870715--KPWPLT
C KPWPLT           ---------------------------------
                    SUBROUTINE KPWPLT (ARRAY,NSTEU)
C                  ---------------------------------
C
C                 Geschrieben:  060856 NOV 85 (Hundt)
C                 Geaendert:    150848 JUL 87 (Hundt)
C
C
C                +----------+             Accepts harware independent
C                |  KPWPLT  |             plot instructions and
C                +----------+             performs "soft zooming"
C                /       |
C              /         |
C            /           |
C           V            |
C      +---------+       |
C      |  UPLOT  |       |               (if wanted:)
C      |  UPDRAW |       |               Suppresses hidden lines
C      +---------+       |
C            \           |
C              \         |
C                \       |
C                  \     |
C                   V    V
C                +----------+            Selects the appropriate
C                |  KPPLOT  |            hardware driver
C                +----------+            (Alternate version:
C                  /  |  \               see below)
C                /    |    \
C              /      |      \
C            /        |        \
C          /          |          \
C         V           V           V
C   +--------+    +--------+   +--------+
C   | TEKPLT |    | HPPLOT |   | TKPRKO |     Hardware drivers
C   +--------+    +--------+   +--------+
C         \           |           /
C           \         |         /
C             \       |       /
C               \     |     /
C                 \   |   /
C                  V  V  V
C                +---------+             Sends the hardware
C                |  TPUTA  |             specific code
C                +---------+             to CRT
C
C
C
C
C              Aternate version
C              ----------------
C                  \     |
C                   V    V
C                +----------+            Aternate version calls
C                |  KPPLOT  |            the HCBS package
C                +----------+
C                  /  |  \
C                /    |    \
C              /      |      \
C            /        |        \
C          /          |          \
C         V           V           V
C   +--------+----+--------+---+--------+
C   | PLOTIN |    |  PLOT  |   | PLTEND |     HCBS package
C   +--------+----+--------+---+--------+
C
C
      DIMENSION ARRAY(*),AKOALT(2),AKONEU(2),AKOPLT(2)
      DIMENSION AKOSAV(2),AKOMRK(4),TBUF(3)
C
      COMMON /KPFCOM/ INTVAR(25),REALAR(25)
C
      EQUIVALENCE (REALAR(1),XMIN),(REALAR(2),XMAX)
      EQUIVALENCE (REALAR(3),YMIN),(REALAR(4),YMAX)
      EQUIVALENCE (AKOALT(1),XALT),(AKOALT(2),YALT)
      EQUIVALENCE (AKONEU(1),XNEU),(AKONEU(2),YNEU)
      EQUIVALENCE (AKOPLT(1),XPLT),(AKOPLT(2),YPLT)
      EQUIVALENCE (AKOMRK(1),XMRK),(AKOMRK(2),YMRK)
      EQUIVALENCE (AKOMRK(3),XMRG),(AKOMRK(4),YMRG)
C
      DATA INFLG /0/,IUFLG/0/,XPG,YPG/0.,0./
      DATA L1/1/,L2/2/,L3/3/,L4/4/,TBUF/0.,1.,1./,IMRK/0/
C
C                            Sprungverteiler
C     +---------+---------------------------------------------+
C     I  NSTEU  I  Bedeutung                                  I
C     +---------+---------------------------------------------+
C     I  < 0    I  -> KPPLOT (Endgueltiges Plotende)          I
C     I    0    I  -> KPPLOT (Temporaeres Plotende)           I
C     I    1    I  -> KPPLOT (Initialisierung)                I
C     I    2    I  PLINE (Linie ziehen)                       I
C     I    3    I  POINT (Hier aufsetzen)                     I
C     I    4    I  -> KPPLOT (Feld Ursprung)                  I
C     I    5    I  -> KPPLOT (Feld Verschiebung)              I
C     I    6    I  -> KPPLOT (Loesche Schirm)                 I
C     I    7    I  Graphischer Cursor on                      I
C     I    8    I  Graphischer Cursorposition besorgen        I
C     I    9    I  -> KPPLOT (Graphischer Cursor aus)         I
C     I   10    I  -> KPPLOT (Penauswahl)                     I
C     I   11    I  Schreibe Text                              I
C     I   12    I  Initialisierung dieses Programms           I
C     I   13    I  Definition des Ausschnitts                 I
C     I   14    I  Ueberzeichnungsflag setzen                 I
C     I   15    I  -> UPLOT (Zeichenfeldabmessungen)          I
C     I   16    I  -> UPLOT (USPERR)                          I
C     I   17    I  -> UPLOT (UOPT)                            I
C     I   18    I  -> KPPLOT (Pixels / cm)                    I
C     I   19    I  -> KPPLOT (Skalenfaktor)                   I
C     I   20    I  -> KPPLOT (Max. Plotfeld)                  I
C     +---------+---------------------------------------------+
C
      ISTEU=NSTEU
      IF (ISTEU) 1040,1040,10
   10 GO TO (1040,140,40,1040,830,1040,720,790,1040,1040,800,20,30,810,
C               1   2  3    4   5    6   7   8    9   10  11 12 13  14
     1 860,880,970,1030,1030), ISTEU
C       15  16  17   18   19
C
C                            Definition der Zeichenfeldabmessungen
   20 XMIN=ARRAY(L1)
      XMAX=XMIN+ARRAY(L2)
      YMIN=ARRAY(L3)
      YMAX=YMIN+ARRAY(L4)
      GO TO 9999
C                            Umblaettern auf einen anderen Ausschnitt
C
   30 XPG=ARRAY(L1)*(XMAX-XMIN)
      YPG=ARRAY(L2)*(YMAX-YMIN)
      GO TO 9999
C                            Aufsetzen bei ARRAY(1),ARRAY(2)
   40 XNEU=ARRAY(L1)-XPG
      YNEU=ARRAY(L2)-YPG
      IF (XNEU-XMIN) 120,50,50
   50 IF (XNEU-XMAX) 60,60,120
   60 IF (YNEU-YMIN) 120,70,70
   70 IF (YNEU-YMAX) 80,80,120
   80 IF (IUFLG) 90,100,90
   90 CALL UPLOT (AKONEU,3)
      GO TO 110
  100 CALL KPPLOT (AKONEU,3)
C                            Punkt liegt innerhalb des Zf.
  110 INFLG=0
      GO TO 130
C                            Punkt liegt auszerhalb des Zeichenfeldes
  120 INFLG=1
C                            Merke die zuletzt eingelaufenen Koord.
  130 XALT=XNEU
      YALT=YNEU
      GO TO 9999
C                            Linie nach ARRAY(1),ARRAY(2)
  140 XNEU=ARRAY(L1)-XPG
      YNEU=ARRAY(L2)-YPG
      XDIFF=XNEU-XALT
      YDIFF=YNEU-YALT
C                            Teste, ob alter Punkt innerhalb lag.
      IF (INFLG) 390,150,390
C                            Alter Punkt lag innerhalb. Teste neuen.
C
  150 IF (XNEU-XMIN) 160,170,170
  160 XPLT=XMIN
      GO TO 190
  170 IF (XNEU-XMAX) 200,200,180
  180 XPLT=XMAX
C                            Neuer Punkt liegt ausserhalb.
C                            Berechne zugehoeriges YPLT.
C
  190 YPLT=YALT+(XPLT-XALT)*YDIFF/XDIFF
C
C                            Teste auch hier auf Grenzuebertritt.
C
      IF (YPLT-YMIN) 210,220,220
  200 IF (YNEU-YMIN) 210,230,230
  210 YPLT=YMIN
      GO TO 250
  220 IF (YPLT-YMAX) 260,260,240
  230 IF (YNEU-YMAX) 300,300,240
  240 YPLT=YMAX
  250 XPLT=XALT+(YPLT-YALT)*XDIFF/YDIFF
  260 IF (INFLG) 340,270,340
  270 INFLG=1
      IF (IUFLG) 280,330,280
C                            Merke Koordinaten.
  280 IF (IMRK-2) 290,290,320
  290 IMRK=IMRK+2
      AKOMRK(IMRK-1)=XPLT
      AKOMRK(IMRK)=YPLT
      GO TO 320
  300 XPLT=XNEU
      YPLT=YNEU
  310 IF (IUFLG) 320,330,320
  320 CALL UPLOT (AKOPLT,2)
      GO TO 130
  330 CALL KPPLOT (AKOPLT,2)
      GO TO 130
  340 INFLG=0
      IF (IUFLG) 350,380,350
C                            Merke Koordinaten.
  350 IF (IMRK-2) 360,360,370
  360 IMRK=IMRK+2
      AKOMRK(IMRK-1)=XPLT
      AKOMRK(IMRK)=YPLT
  370 CALL UPLOT (AKOPLT,3)
      CALL UPLOT (AKOALT,2)
      GO TO 9999
  380 CALL KPPLOT (AKOPLT,3)
      CALL KPPLOT (AKOALT,2)
      GO TO 9999
C                            Alter Punkt lag ausserhalb.
  390 IXFLG=0
C                            Teste, ob auch neuer Punkt ausserhalb.
C
      IF (XNEU-XMIN) 400,420,420
  400 IF (XALT-XMIN) 130,410,410
  410 XPLTT=XMAX
      GO TO 450
  420 IF (XNEU-XMAX) 460,460,430
  430 IF (XALT-XMAX) 440,440,130
  440 XPLTT=XMIN
  450 IXFLG=1
  460 IF (YNEU-YMIN) 470,490,490
  470 IF (YALT-YMIN) 130,480,480
  480 YPLTT=YMAX
       GO TO 520
  490 IF (YNEU-YMAX) 590,590,500
  500 IF (YALT-YMAX) 510,510,130
  510 YPLTT=YMIN
  520 XPLT=XALT+(YPLTT-YALT)*XDIFF/YDIFF
      IF (XPLT-XMIN) 530,540,540
  530 XPLT=XMIN
      GO TO 560
  540 IF (XPLT-XMAX) 580,580,550
  550 XPLT=XMAX
  560 YPLT=YALT+(XPLT-XALT)*YDIFF/XDIFF
      IF (YPLT-YMIN) 130, 570,570
  570 IF (YPLT-YMAX) 680,680,130
  580 YPLT=YPLTT
      GO TO 680
  590 IF (IXFLG) 610,600,610
  600 TEMP=XALT
      XALT=XNEU
      XNEU=TEMP
      TEMP=YALT
      YALT=YNEU
      YNEU=TEMP
      GO TO 150
  610 YPLT=YALT+(XPLTT-XALT)*YDIFF/XDIFF
      IF (YPLT-YMIN) 620,630,630
  620 YPLT=YMIN
      GO TO 650
  630 IF (YPLT-YMAX) 670,670,640
  640 YPLT=YMAX
  650 XPLT=XALT+(YPLT-YALT)*XDIFF/YDIFF
      IF (XPLT-XMIN) 130,660,660
  660 IF (XPLT-XMAX) 680,680,130
  670 XPLT=XPLTT
  680 IF (IUFLG) 690,700,690
  690 CALL UPLOT (AKOPLT,3)
      GO TO 710
  700 CALL KPPLOT (AKOPLT,3)
  710 XALT=XPLT
      YALT=YPLT
      INFLG=0
      GO TO 150
C                           -----------------------
C                            Graphischer Cursor an
C                           -----------------------
  720 IRET=0
  730 AKOSAV(1)=ARRAY(L1)
      AKOSAV(2)=ARRAY(L2)
      ARRAY(L1)=AKOSAV(1)-XPG
      ARRAY(L2)=AKOSAV(2)-YPG
      IF (ARRAY(L1)-XMIN) 780,750,740
  740 IF (ARRAY(L1)-XMAX) 750,750,780
  750 IF (ARRAY(L2)-YMIN) 780,770,760
  760 IF (ARRAY(L2)-YMAX) 770,770,780
  770 IF (IRET) 850,840,840
  780 ISTEU=9
      GO TO 840
C                           --------------------------
C                            Cursor-Position besorgen
C                           --------------------------
C
  790 CALL KPPLOT (ARRAY,ISTEU)
      ARRAY(L1)=ARRAY(L1)+XPG
      ARRAY(L2)=ARRAY(L2)+YPG
      GO TO 9999
C                           ----------------
C                            Schreibe Label
C                           ----------------
C                            ARRAY(1): x; (2): y; (3): Schrifthoehe;
C                            (4): Zahl der Buchstaben; (5): Textanfang
  800 IRET=1
      GO TO 730
C                            Der Flag "IUFLG" wird gesetzt, wenn mit
C                            Beruecksichtigung von verdeckten Linien
C                            gezeichnet wird.
  810 IUFLG=ARRAY(L1)
      IF (IUFLG) 820,9999,820
  820 CALL UPLOT (REALAR,1)
      GO TO 9999
C
  830 AKOSAV(1)=ARRAY(L1)
      AKOSAV(2)=ARRAY(L2)
  840 CALL KPPLOT (ARRAY,ISTEU)
C
C                            Restore alte Koordinaten
  850 ARRAY(L1)=AKOSAV(1)
      ARRAY(L2)=AKOSAV(2)
      GO TO 9999
C                            USET
  860 ISTEU=1
      GO TO 980
C                            USPERR.  Teste, ob Randline pending.
  870 IMRK=IMRK-10
  880 IF (IMRK-4) 960,890,870
  890 IF (XMRK-XMAX) 900,910,900
  900 IF (XMRK-XMIN) 920,910,920
C  910 XMERG=XMERK               !       In original XMERK was undefined AWH

  910 XMERG=XMRK                     !   Assume XMERK should have been XMRK AWH

      GO TO 950
  920 IF (XMRG-XMAX) 930,940,930
  930 IF (XMRG-XMIN) 960,940,960
  940 XMRK=XMERG
  950 CONTINUE
      CALL UPLOT (TBUF,5)
      CALL UPLOT (AKOMRK,3)
      CALL UPLOT (AKOMRK(3),2)
      CALL UPLOT (TBUF(2),5)
  960 IMRK=0
      ISTEU=4
      GO TO 980
C                            UOPT
  970 ISTEU=5
  980 CALL UPLOT (ARRAY,ISTEU)
      IF (ISTEU-5) 9999,990,9999
C
C                            Wenn nur abgezogen werden soll oder wenn
C                            nicht protokolliert wird, dann wird eine
C                            Randueberschreitung nicht beachtet.
C
  990 IF (ARRAY(L2)) 1000,1000,1020
 1000 IMRK=IMRK+10
      GO TO 9999
 1010 IMRK=IMRK-10
 1020 IF (IMRK-10) 9999,1010,1010
 1030 ISTEU=ISTEU-6
 1040 CALL KPPLOT (ARRAY,ISTEU)
C
 9999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--KPZ
                          SUBROUTINE KPZ
      DIMENSION ST(3,3),DGH(3,3),STRN(12,12),ZELLSV(6)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      EQUIVALENCE (CONST(3),BOG),(AIN(1),ST(1,1)),(AIN(10),DGH(1,1))
      EQUIVALENCE (ATOMS(1,1),STRN(1,1))
      DATA IBLANK/4H    /,ZELLSV/3*1.,3*90./
      GO TO (20,300,250,500,690,10), NTYP
   10 IOPT=1
      GO TO 30
   20 IOPT=0
   30 IF (ISKP(14)) 60,40,60
   40 DO 50 I=1,6
   50 ZELLSV(I)=ZELLE(I)
      ZELLE(2)=0.
      ZELLE(3)=0.
      CALL FLES (ZELLE,ISKP(31),4H6FE ,24Ha,b,c,alpha,beta,gamma?$)
   60 IF (ZELLE(1)) 990,990,70
   70 IF (ZELLE(2)) 80,80,90
   80 ZELLE(2)=ZELLE(1)
   90 IF (ZELLE(3)) 100,100,110
  100 ZELLE(3)=ZELLE(1)
  110 DO 130 I=4,6
      IF (ZELLE(I)) 120,120,130
  120 ZELLE(I)=90.
  130 CONTINUE
  140 DO 150 I=1,3
      DO 150 J=1,3
      S(I,J)=DG(I,J)
      DG(I,J)=0.
  150 RG(I,J)=0.
      DG(1,1)=ZELLE(1)
      DG(1,2)=ZELLE(2)*COS(ZELLE(6)*BOG)
      DG(2,2)=SQRT(ZELLE(2)*ZELLE(2)-DG(1,2)*DG(1,2))
      DG(1,3)=ZELLE(3)*COS(ZELLE(5)*BOG)
      DG(2,3)=(ZELLE(2)*ZELLE(3)*COS(ZELLE(4)*BOG)-DG(1,2)*DG(1,3))
     1 / DG(2,2)
      DG(3,3)=SQRT(ZELLE(3)*ZELLE(3)-DG(1,3)*DG(1,3)-DG(2,3)*DG(2,3))
      RG(1,1)=1./DG(1,1)
      RG(2,2)=1./DG(2,2)
      RG(3,3)=1./DG(3,3)
      RG(2,1)=-DG(1,2)/(DG(2,2)*DG(1,1))
      RG(3,2)=-DG(2,3)/(DG(2,2)*DG(3,3))
      RG(3,1)=(DG(1,2)*DG(2,3)/DG(2,2)-DG(1,3))/(DG(1,1)*DG(3,3))
      IF (IOPT) 160,220,160
  160 IF (NAT) 220,220,170
  170 DO 180 I=1,3
      DO 180 J=1,3
      X(I,J)=RG(1,I)*S(1,J)+RG(2,I)*S(2,J)+RG(3,I)*S(3,J)
  180 CONTINUE
      DO 210 I=1,NAT
      DO 190 J=1,3
  190 T(J)=AT(J,I)
      DO 200 J=1,3
  200 AT(J,I)=X(J,1)*T(1)+X(J,2)*T(2)+X(J,3)*T(3)
  210 CONTINUE
  220 DO 240 I=1,3
      TEMP=0.
      DO 230 J=1,3
      TEMP=TEMP+RG(J,I)*RG(J,I)
  230 CONTINUE
      RK(I)=SQRT(TEMP)
  240 CONTINUE
  250 DO 270 I=1,3
      UR(I)=0.
      DO 260 J=1,3
      DREH(I,J)=0.
      TRA(I,J)=DG(I,J)
      TRAINV(I,J)=RG(J,I)
  260 CONTINUE
      DREH(I,I)=1.
  270 CONTINUE
      K8=0
      K9=0
      IF (NTYP-2) 999,999,280
  280 IF (NTYP-6) 290,999,290
  290 CALL FLES (AIN,ISKP(31),1HE,2H?$)
      GO TO 999
  300 DO 310 I=1,72
  310 AIN(I)=0.
      ISKP(16)=IBLANK
      ISKP(17)=IBLANK
      ISKP(18)=0
      CALL FLES (AIN,ISKP(31),3H9FE,19Hs11,s12, ..., s33?$)
      IF (ISKP(31)-9) 320,330,330
  320 ISKP(10)=200320
      IERR=16
      GO TO 999
  330 DO 340 I=1,6
  340 ZELLSV(I)=ZELLE(I)
      DO 350 I=1,3
      DO 350 J=1,3
      DGH(I,J)=DG(I,1)*ST(1,J)+DG(I,2)*ST(2,J)+DG(I,3)*ST(3,J)
      STRN(I+9,J+9)=ST(J,I)
  350 CONTINUE
      DO 360 I=1,3
      DO 360 J=I,3
      DG(I,J)=DGH(1,I)*DGH(1,J)+DGH(2,I)*DGH(2,J)+DGH(3,I)*DGH(3,J)
  360 CONTINUE
      DG(3,1)=DG(1,3)
      DO 370 I=1,3
  370 ZELLE(I)=SQRT(DG(I,I))
      DO 380 I=1,3
      J=ID2(I)
      K=ID2(J)
      ZELLE(K+3)=CONST(4)*ACOS(DG(I,J)/(ZELLE(I)*ZELLE(J)))
  380 CONTINUE
      CALL MINV (ST,3,TEMP,AIN(19),AIN(22))
      IF (NAT) 430,430,390
  390 DO 420 K=1,NAT
      DO 400 I=1,3
  400 T(I)=ST(I,1)*AT(1,K)+ST(I,2)*AT(2,K)+ST(I,3)*AT(3,K)
      DO 410 I=1,3
  410 AT(I,K)=T(I)
  420 CONTINUE
  430 DO 450 I1=1,9,4
      DO 450 J1=1,9,4
      TEMP=ST((I1-1)/4+1,(J1-1)/4+1)
      STRN(I1,J1)=TEMP
      DO 440 I=1,3
      STRN(I+I1,J1)=0.
      STRN(I1,I+J1)=0.
      DO 440 J=1,3
      STRN(I+I1,J+J1)=STRN(I+9,J+9)*TEMP
  440 CONTINUE
  450 CONTINUE
      IF (NSYM) 140,140,460
  460 DO 490 I=1,NSYM
      DO 470 J=1,12
  470 AIN(J)=SYM(J,I)
      DO 480 J=1,12
      SYM(J,I)=0.
      DO 480 K=1,12
      SYM(J,I)=SYM(J,I)+STRN(J,K)*AIN(K)
  480 CONTINUE
  490 CONTINUE
      ASSIGN 140 TO NRMRET
      GO TO 570
  500 CALL FLES (AIN,ISKP(31),3H3FE,7Hx,y,z?$)
      ISKP(16)=IBLANK
      ISKP(17)=IBLANK
      ISKP(18)=0
      IF (NSYM) 540,540,510
  510 DO 530 I=1,NSYM
      J=1
      DO 520 K=1,3
      SYM(J,I)=SYM(J,I)-AIN(K)+SYM(J+1,I)*AIN(1)+SYM(J+2,I)*AIN(2)
     1 + SYM(J+3,I)*AIN(3)
      J=J+4
  520 CONTINUE
  530 CONTINUE
      ASSIGN 540 TO NRMRET
      GO TO 570
  540 IF (NAT) 999,999,550
  550 DO 560 I=1,NAT
      DO 560 K=1,3
      AT(K,I)=AT(K,I)-AIN(K)
  560 CONTINUE
      GO TO 999
  570 DO 670 I=1,NSYM
      DO 660 J=1,9,4
      TEMP=SYM(J,I)
      GO TO 590
  580 TEMP=TEMP+1.
  590 IF (TEMP) 600,650,620
  600 IF (TEMP+0.001) 580,640,640
  610 TEMP=TEMP-1.
  620 IF (TEMP-1.) 630,640,610
  630 IF (TEMP-0.999) 650,640,640
  640 TEMP=0.
  650 SYM(J,I)=TEMP
  660 CONTINUE
  670 CONTINUE
  680 IOPT=0
      GO TO NRMRET,(140,540)
  690 DO 700 I=1,6
  700 ZELLE(I)=ZELLSV(I)
      IOPT=0
      GO TO 60
  990 IERR=10
      ISKP(10)=200990
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880601--KPZK
                          SUBROUTINE KPZK
      DIMENSION AINBFR(3)
      COMMON /KPCOM/ ZELLE(6),DG(3,3),RG(3,3),RK(3)
      COMMON /KPCOM/ TRA(3,3),TRAINV(3,3),UR(3),DREH(3,3),HOE,ID2(3)
      COMMON /KPCOM/ SYM(12,48),NSYM,NSYMDM
      COMMON /KPCOM/ AT(6,200),NAT,NATDM,GRID(3)
      COMMON /KPCOM/ ICD(500),NCD,NCDDM,IC,NCDA,ATOMS(3,500),K8,K9
      COMMON /KPCOM/ CDS(7),NC,AIN(72),TITEL(18),O8,O9,IERR,FKGL
      COMMON /KPCOM/ X(3,7),X1(3),X2(3),S(3,3),T(3)
      COMMON /KPCOM/ NTIN,NTOUT,NTPCH,NTSCR
      COMMON /KPCOM/ NTXR1,NTXR2,NTBILF,NTDTEI,NTTEMP
      COMMON /KPCOM/ NTRY,NTYP,DQ,IZ1,IZ2,IANR,ISYNR,IT(3)
      COMMON /KPCOM/ IPK(400),IPKP,IPKDM
      COMMON /KPCOM/ CONST(40),PTRIKL(3),PFREI(3),ISKP(40)
      COMMON /KPCOM/ NPLST(102)
      DATA AINBFR/1.5,1.5,10./
      CALL FLES (AINBFR,ISKP(31),3H3FE,16Hx,y,Schritte/A?$)
      MX=AINBFR(1)*AINBFR(3)
      MY=AINBFR(2)*AINBFR(3)
      TMPFKT=HOE/(HOE-PFREI(3))*O8
      AIN(3)=-AINBFR(1)
      AIN(4)=0.
      AIN(5)=AINBFR(1)
      AIN(6)=0.
      ASSIGN 10 TO NRET
      GO TO 140
   10 AIN(4)=-AINBFR(2)
      AIN(3)=0.
      AIN(6)=AINBFR(2)
      AIN(5)=0.
      ASSIGN 20 TO NRET
      GO TO 140
   20 I=-MX
      ASSIGN 70 TO NRET
   30 AIN(3)=FLOAT(I)/AINBFR(3)
      AIN(4)=0.
      AIN(5)=AIN(3)
      AIN(6)=0.1
      M=ABS(AIN(3)*10.)+.5
      M=MOD(M,10)
      IF (M) 50,40,50
   40 AIN(6)=.4
      GO TO 140
   50 IF (M-5) 140,60,140
   60 AIN(6)=.2
      GO TO 140
   70 I=I+1
      IF (I-MX) 30,30,80
   80 I=-MY
      AIN(3)=0.
      ASSIGN 130 TO NRET
   90 AIN(4)=FLOAT(I)/AINBFR(3)
      AIN(5)=0.1
      AIN(6)=AIN(4)
      M=ABS(AIN(4)*10.)+.5
      M=MOD(M,10)
      IF (M) 110,100,110
  100 AIN(5)=.4
      GO TO 140
  110 IF (M-5) 140,120,140
  120 AIN(5)=.2
      GO TO 140
  130 I=I+1
      IF (I-MY) 90,90,180
  140 II=3
      ITYP=3
  150 AIN(1)=(PFREI(1)+AIN(II))*TMPFKT+CONST(11)
      AIN(2)=(PFREI(2)+AIN(II+1))*TMPFKT+CONST(12)
      CALL KPWPLT (AIN,ITYP)
      IF (ITYP-3) 160,170,160
  160 GO TO NRET, (10,20,70,130)
  170 ITYP=2
      II=5
      GO TO 150
  180 CALL KPWPLT (AIN,0)
      RETURN
      END
C ----------------------------------------OWNUNC404----UPD860606--MINV
      SUBROUTINE MINV(A,N,D,L,M)
      DIMENSION A(*),L(*),M(*)
      D=1.0
      NK=-N
      DO 80 K=1,N
      NK=NK+N
      L(K)=K
      M(K)=K
      KK=NK+K
      BIGA=A(KK)
      DO 20 J=K,N
      IZ=N*(J-1)
      DO 20 I=K,N
      IJ=IZ+I
   10 IF( ABS(BIGA)- ABS(A(IJ))) 15,20,20
   15 BIGA=A(IJ)
      L(K)=I
      M(K)=J
   20 CONTINUE
      J=L(K)
      IF(J-K) 35,35,25
   25 KI=K-N
      DO 30 I=1,N
      KI=KI+N
      HOLD=-A(KI)
      JI=KI-K+J
      A(KI)=A(JI)
   30 A(JI) =HOLD
   35 I=M(K)
      IF(I-K) 45,45,38
   38 JP=N*(I-1)
      DO 40 J=1,N
      JK=NK+J
      JI=JP+J
      HOLD=-A(JK)
      A(JK)=A(JI)
   40 A(JI) =HOLD
   45 IF(BIGA) 48,46,48
   46 D=0.0
      RETURN
   48 DO 55 I=1,N
      IF(I-K) 50,55,50
   50 IK=NK+I
      A(IK)=A(IK)/(-BIGA)
   55 CONTINUE
      DO 65 I=1,N
      IK=NK+I
      HOLD=A(IK)
      IJ=I-N
      DO 65 J=1,N
      IJ=IJ+N
      IF(I-K) 60,65,60
   60 IF(J-K) 62,65,62
   62 KJ=IJ-I+K
      A(IJ)=HOLD*A(KJ)+A(IJ)
   65 CONTINUE
      KJ=K-N
      DO 75 J=1,N
      KJ=KJ+N
      IF(J-K) 70,75,70
   70 A(KJ)=A(KJ)/BIGA
   75 CONTINUE
      D=D*BIGA
      A(KK)=1.0/BIGA
   80 CONTINUE
      K=N
  100 K=(K-1)
      IF(K) 150,150,105
  105 I=L(K)
      IF(I-K) 120,120,108
  108 JQ=N*(K-1)
      JR=N*(I-1)
      DO 110 J=1,N
      JK=JQ+J
      HOLD=A(JK)
      JI=JR+J
      A(JK)=-A(JI)
  110 A(JI) =HOLD
  120 J=M(K)
      IF(J-K) 100,100,125
  125 KI=K-N
      DO 130 I=1,N
      KI=KI+N
      HOLD=A(KI)
      JI=KI-K+J
      A(KI)=-A(JI)
  130 A(JI) =HOLD
      GO TO 100
  150 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880527--UDRAW
                   SUBROUTINE UDRAW (MATRIX,MATPRT)
       DIMENSION MATRIX(10,320),MATPRT(2,320),ARRAY(2)
      DIMENSION LINE(3,64),AKOALT(2),AKONEU(2),AKOPNT(2)
      DIMENSION ITAB(32),ITABL(32),ITABR(32)
      EQUIVALENCE (AKOALT(1),XALT),(AKOALT(2),YALT)
      EQUIVALENCE (AKONEU(1),XNEU),(AKONEU(2),YNEU)
      EQUIVALENCE (AKOPNT(1),PNT1),(AKOPNT(2),PNT2)
      DATA IXDIM/320/,IYDIM/320/,KBIT/32/,NTOUT/6/,LINEDM/64/
      DATA L1/1/,L2/2/,L3/3/,L4/4/
       DATA ITAB/Z'80000000',Z'40000000',Z'20000000',Z'10000000',
     1 Z'8000000',Z'4000000',Z'2000000',Z'1000000',Z'800000',
     2 Z'400000',Z'200000',Z'100000',Z'80000',Z'40000',Z'20000',
     3 Z'10000',Z'8000',Z'4000',Z'2000',Z'1000',Z'800',Z'400',
     4 Z'200',Z'100',Z'80',Z'40',Z'20',Z'10',Z'8',Z'4',Z'2',Z'1'/
C
       DATA ITABL/Z'80000000',Z'C0000000',Z'E0000000',
     1 Z'F0000000',Z'F8000000',Z'FC000000',Z'FE000000',
     2 Z'FF000000',Z'FF800000',Z'FFC00000',Z'FFE00000',
     3 Z'FFF00000',Z'FFF80000',Z'FFFC0000',Z'FFFE0000',
     4 Z'FFFF0000',Z'FFFF8000',Z'FFFFC000',Z'FFFFE000',
     5 Z'FFFFF000',Z'FFFFF800',Z'FFFFFC00',Z'FFFFFE00',
     6 Z'FFFFFF00',Z'FFFFFF80',Z'FFFFFFC0',Z'FFFFFFE0',
     7 Z'FFFFFFF0',Z'FFFFFFF8',Z'FFFFFFFC',Z'FFFFFFFE',
     8 Z'FFFFFFFF'/
C
       DATA ITABR/Z'FFFFFFFF',Z'7FFFFFFF',Z'3FFFFFFF',Z'1FFFFFFF',
     1 Z'FFFFFFF',Z'7FFFFFF',Z'3FFFFFF',Z'1FFFFFF',Z'FFFFFF',
     2 Z'7FFFFF',Z'3FFFFF',Z'1FFFFF',Z'FFFFF',Z'7FFFF',Z'3FFFF',
     3 Z'1FFFF',Z'FFFF',Z'7FFF',Z'3FFF',Z'1FFF',Z'FFF',Z'7FF',
     4 Z'3FF',Z'1FF',Z'FF',Z'7F',Z'3F',Z'1F',Z'F',Z'7',Z'3',Z'1'/
      DATA A1/0./,A2/0./,B1/0./,B2/0./
      DATA IYMIN/0/,IYMAX/0/,NPROT/1/,IZCHN/1/,LINEMX/0/
      GO TO 999
      ENTRY UPLOT (ARRAY,NSTEU)
      IF (NSTEU) 999,999,10
   10 GO TO (20,140,100,720,90), NSTEU
   20 PNT=ARRAY(L2)-ARRAY(L1)
      IF (PNT) 40,40,30
   30 A1=FLOAT(IXDIM-1)/PNT
      PNT=ARRAY(L4)-ARRAY(L3)
      IF (PNT) 40,40,60
   40 WRITE (NTOUT,50) (ARRAY(I),I=1,4)
   50 FORMAT (' *USET*   Feldbegrenzung unbrauchbar:',4F10.2)
      GO TO 999
   60 A2=FLOAT(IYDIM-1)/PNT
      B1=1.-A1*ARRAY(L1)
      B2=1.-A2*ARRAY(L3)
      JE=IXDIM/KBIT
      DO 80 I=1,IYDIM
      DO 70 J=1,JE
   70 MATRIX(J,I)=0
      MATPRT(1,I)=IXDIM+1
      MATPRT(2,I)=0
   80 CONTINUE
      IYMIN=IYDIM+1
      IYMAX=0
      NPROT=1
      IZCHN=1
      LINEMX=0
      GO TO 999
   90 IZCHN=ARRAY(L1)
      NPROT=ARRAY(L2)
      GO TO 999
  100 XALT=ARRAY(L1)
      YALT=ARRAY(L2)
      IPENUP=1
      IXV=A1*XALT+B1
      IF (IXV) 180,180,110
  110 IF (IXV-IXDIM) 120,120,180
  120 IYV=A2*YALT+B2
      IF (IYV) 180,180,130
  130 IF (IYV-IYDIM) 999,999,180
  140 XNEU=ARRAY(L1)
      YNEU=ARRAY(L2)
      IXN=A1*XNEU+B1
      IF (IXN) 180,180,150
  150 IF (IXN-IXDIM) 160,160,180
  160 IYN=A2*YNEU+B2
      IF (IYN) 180,180,170
  170 IF (IYN-IYDIM) 200,200,180
  180 WRITE (NTOUT,190) ARRAY(L1),ARRAY(L2)
  190 FORMAT (' *UDRAW*  Randueberschreitung.',2F10.2)
      GO TO 999
  200 IXED=IXN-IXV
      IXD=IXED
      IYED=IYN-IYV
      IYD=IYED
      IX1=1
      IF (IXD) 210,220,220
  210 IX1=-1
      IXD=-IXD
  220 IXD=IXD+1
      IY1=1
      IF (IYD) 230,240,240
  230 IY1=-1
      IYD=-IYD
  240 IYD=IYD+1
      IERSTP=1
      IF (IXD-IYD) 290,250,270
  250 IF (IXED) 270,260,270
  260 NRET=-1
      GO TO 400
  270 INC=IYD
      NRET=0
      IF (IZCHN) 280,400,280
  280 PNT1=IXED
      PNT2=IXV
      GO TO 310
  290 INC=IXD
      NRET=1
      IF (IZCHN) 300,400,300
  300 PNT1=IYED
      PNT2=IYV
  310 AA1=(XNEU-XALT)/PNT1
      AA2=(YNEU-YALT)/PNT1
      BB1=XALT-AA1*PNT2
      BB2=YALT-AA2*PNT2
      GO TO 400
  320 IERSTP=0
  330 IF (NRET) 680,340,370
  340 IF (IXV-IXN) 350,680,350
  350 IXV=IXV+IX1
      INC=INC+IYD
      ITEMP=INC-IXD
      IF (ITEMP) 400,400,360
  360 INC=ITEMP
      IYV=IYV+IY1
      GO TO 400
  370 IF (IYV-IYN) 380,680,380
  380 IYV=IYV+IY1
      INC=INC+IXD
      ITEMP=INC-IYD
      IF (ITEMP) 400,400,390
  390 INC=ITEMP
      IXV=IXV+IX1
  400 IF (NPROT) 410,520,510
  410 I=1
      IF (IYV-IYMIN) 520,450,420
  420 IF (IYV-IYMAX) 450,450,520
  430 IF (LINE(1,I)-IYV) 440,500,440
  440 I=I+1
  450 IF (I-LINEMX) 430,430,460
  460 IF (LINEMX-LINEDM) 490,470,470
  470 WRITE (NTOUT,480)
  480 FORMAT (' *UDRAW*  LINE-Puffer zu klein.')
      GO TO 520
  490 LINEMX=I
      LINE(1,I)=IYV
      LINE(2,I)=IXV
      LINE(3,I)=IXV
      GO TO 520
  500 LINE(2,I)=MIN0(LINE(2,I),IXV)
      LINE(3,I)=MAX0(LINE(3,I),IXV)
      GO TO 520
  510 MATPRT(1,IYV)=MIN0(MATPRT(1,IYV),IXV)
      MATPRT(2,IYV)=MAX0(MATPRT(2,IYV),IXV)
      IYMIN=MIN0(IYMIN,IYV)
      IYMAX=MAX0(IYMAX,IYV)
  520 IF (IZCHN) 530,330,530
  530 IW=(IXV-1)/KBIT
      IB=IXV-KBIT*IW
      IF (IAND(MATRIX(IW+1,IYV),ITAB(IB))) 610,540,610
  540 IF (IPENUP) 550,600,550
  550 IF (NRET) 560,570,580
  560 CALL KPPLOT (AKOALT,3)
      IPENUP=0
      GO TO 700
  570 PNT=IXV
      GO TO 590
  580 PNT=IYV
  590 PNT1=AA1*PNT+BB1
      PNT2=AA2*PNT+BB2
      CALL KPPLOT (AKOPNT,3)
      IPENUP=0
  600 IXALT=IXV
      IYALT=IYV
      GO TO 320
  610 IF (IPENUP) 320,620,320
  620 IF (IERSTP) 670,630,670
  630 IF (NRET) 670,640,650
  640 PNT=IXALT
      GO TO 660
  650 PNT=IYALT
  660 PNT1=AA1*PNT+BB1
      PNT2=AA2*PNT+BB2
      CALL KPPLOT (AKOPNT,2)
  670 IPENUP=1
      GO TO 320
  680 IF (IZCHN) 690,710,690
  690 IF (IPENUP) 710,700,710
  700 CALL KPPLOT (AKONEU,2)
  710 XALT=XNEU
      YALT=YNEU
      GO TO 999
  720 IF (LINEMX) 820,820,730
  730 DO 810 I=1,LINEMX
      J=LINE(1,I)
      IB=LINE(2,I)
      IW=LINE(3,I)
      MATP1J=MATPRT(1,J)
      MATP2J=MATPRT(2,J)
      IF (IB-MATP1J) 740,740,780
  740 IF (IW-MATP1J) 810,750,750
  750 IF (IW-MATP2J) 760,760,770
  760 MATPRT(1,J)=IW+1
      GO TO 810
  770 MATPRT(1,J)=IXDIM+1
      MATPRT(2,J)=0
      GO TO 810
  780 IF (IB-MATP2J) 790,790,810
  790 IF (IW-MATP2J) 810,800,800
  800 MATPRT(2,J)=IB-1
  810 CONTINUE
      LINEMX=0
  820 IF (IYMIN-IYMAX) 830,830,999
  830 DO 890 I=IYMIN,IYMAX
      J=MATPRT(1,I)
      K=MATPRT(2,I)
      IF (J-K) 840,840,890
  840 IW=(J-1)/KBIT
      IB=J-KBIT*IW
      IW2=(K-1)/KBIT
      IB2=K-KBIT*IW2
      IW2=IW2+1
      J=ITABR(IB)
      GO TO 870
  850 CONTINUE
      J=IAND(J,ITABL(IB2))
  860 CONTINUE
      MATRIX(IW,I)=IOR(J,MATRIX(IW,I))
      J=ITABR(1)
  870 IW=IW+1
      IF (IW-IW2) 860,850,880
  880 MATPRT(1,I)=IXDIM+1
      MATPRT(2,I)=0
  890 CONTINUE
      IYMIN=IYDIM+1
      IYMAX=0
  999 RETURN
      END
C ----------------------------------------OWNUNC404----UPD880603--TPUTA
      SUBROUTINE TPUTA (STRING,LENGTH)
C
C ---THIS IS THE GRAPHICS SCREEN SIMULATOR OF THE KPLOT SYSTEM.
C     STRING CONTAINS THE COMPLETE CONTROL CODE USED BY THE
C     GRAPHICS TERMINAL (INCLUDING ESCAPE SEQUENCES ETC.).
C     IN THE MOMENT TPUTA IS CALLED BY: TEKPLT, HPPLOT, TKPRKO
C
      CHARACTER*1 STRING(*)
C
      WRITE (6,100) (STRING(J),J=1,LENGTH)
100   FORMAT(1X,80A1)
C
      RETURN
      END
cuw---------------------------------------------
      subroutine kpplot(dummy1,dummy2)
cuw--------------------------------------------
c
c     dummy routine fuer kpplot (s. Crystin)
c
c     U. Wedig
c
      return
      end
